diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor
index a72960f20f..cbbebde579 100755
--- a/basis/alarms/alarms.factor
+++ b/basis/alarms/alarms.factor
@@ -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? ;
diff --git a/basis/alias/alias-docs.factor b/basis/alias/alias-docs.factor
new file mode 100644
index 0000000000..f4d4ac0361
--- /dev/null
+++ b/basis/alias/alias-docs.factor
@@ -0,0 +1,17 @@
+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 "USING: alias prettyprint sequences ;"
+ "IN: alias.test"
+ "ALIAS: sequence-nth nth"
+ "0 { 10 20 30 } sequence-nth ."
+ "10"
+ }
+} ;
+
+
diff --git a/basis/alias/authors.txt b/basis/alias/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/alias/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor
index 81e9ab97f7..2c464cc74c 100755
--- a/basis/alien/structs/structs-docs.factor
+++ b/basis/alien/structs/structs-docs.factor
@@ -1,13 +1,13 @@
IN: alien.structs
USING: alien.c-types strings help.markup help.syntax
alien.syntax sequences io arrays slots.deprecated
-kernel words slots assocs namespaces ;
+kernel words slots assocs namespaces accessors ;
! Deprecated code
: ($spec-reader-values) ( slot-spec class -- element )
dup ?word-name swap 2array
- over slot-spec-name
- rot slot-spec-class 2array 2array
+ over name>>
+ rot class>> 2array 2array
[ { $instance } swap suffix ] assoc-map ;
: $spec-reader-values ( slot-spec class -- )
@@ -16,14 +16,14 @@ kernel words slots assocs namespaces ;
: $spec-reader-description ( slot-spec class -- )
[
"Outputs the value stored in the " ,
- { $snippet } rot slot-spec-name suffix ,
+ { $snippet } rot name>> suffix ,
" slot of " ,
{ $instance } swap suffix ,
" instance." ,
] { } make $description ;
: slot-of-reader ( reader specs -- spec/f )
- [ slot-spec-reader eq? ] with find nip ;
+ [ reader>> eq? ] with find nip ;
: $spec-reader ( reader slot-specs class -- )
>r slot-of-reader r>
@@ -46,14 +46,14 @@ M: word slot-specs "slots" word-prop ;
: $spec-writer-description ( slot-spec class -- )
[
"Stores a new value to the " ,
- { $snippet } rot slot-spec-name suffix ,
+ { $snippet } rot name>> suffix ,
" slot of " ,
{ $instance } swap suffix ,
" instance." ,
] { } make $description ;
: slot-of-writer ( writer specs -- spec/f )
- [ slot-spec-writer eq? ] with find nip ;
+ [ writer>> eq? ] with find nip ;
: $spec-writer ( writer slot-specs class -- )
>r slot-of-writer r>
diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index 8671b77c9e..51283e2956 100755
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -11,17 +11,17 @@ IN: alien.structs
: struct-offsets ( specs -- size )
0 [
[ class>> align-offset ] keep
- [ set-slot-spec-offset ] 2keep
+ [ (>>offset) ] 2keep
class>> heap-size +
] reduce ;
: define-struct-slot-word ( spec word quot -- )
- rot slot-spec-offset prefix define-inline ;
+ rot offset>> prefix define-inline ;
: define-getter ( type spec -- )
[ set-reader-props ] keep
[ ]
- [ slot-spec-reader ]
+ [ reader>> ]
[
class>>
[ c-getter ] [ c-type c-type-boxer-quot ] bi append
@@ -31,7 +31,7 @@ IN: alien.structs
: define-setter ( type spec -- )
[ set-writer-props ] keep
[ ]
- [ slot-spec-writer ]
+ [ writer>> ]
[ class>> c-setter ] tri
define-struct-slot-word ;
diff --git a/basis/ascii/ascii.factor b/basis/ascii/ascii.factor
index 30b801a950..c009c66cde 100755
--- a/basis/ascii/ascii.factor
+++ b/basis/ascii/ascii.factor
@@ -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|| ;
diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor
index 86c58af505..9958e7943f 100644
--- a/basis/base64/base64-tests.factor
+++ b/basis/base64/base64-tests.factor
@@ -1,4 +1,5 @@
USING: kernel tools.test base64 strings ;
+IN: base64.tests
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
] unit-test
diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor
index d48abc2014..3bf1a527ea 100644
--- a/basis/base64/base64.factor
+++ b/basis/base64/base64.factor
@@ -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
diff --git a/basis/biassocs/biassocs.factor b/basis/biassocs/biassocs.factor
index cd1e57f6ec..a9f0cabd10 100644
--- a/basis/biassocs/biassocs.factor
+++ b/basis/biassocs/biassocs.factor
@@ -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 ;
diff --git a/basis/bootstrap/handbook/handbook.factor b/basis/bootstrap/handbook/handbook.factor
index 2ffb77de7a..51aa9eefaf 100755
--- a/basis/bootstrap/handbook/handbook.factor
+++ b/basis/bootstrap/handbook/handbook.factor
@@ -1,3 +1,4 @@
USING: vocabs.loader vocabs kernel ;
+IN: bootstrap.handbook
"bootstrap.help" vocab [ "help.handbook" require ] when
diff --git a/basis/bootstrap/random/random.factor b/basis/bootstrap/random/random.factor
index 5f5e11d913..3782d517cf 100755
--- a/basis/bootstrap/random/random.factor
+++ b/basis/bootstrap/random/random.factor
@@ -1,6 +1,7 @@
USING: vocabs.loader sequences system
random random.mersenne-twister combinators init
namespaces random ;
+IN: bootstrap.random
"random.mersenne-twister" require
diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor
index f9d51b3dfc..c6ec7f0b99 100755
--- a/basis/bootstrap/tools/tools.factor
+++ b/basis/bootstrap/tools/tools.factor
@@ -1,4 +1,5 @@
USING: vocabs.loader sequences ;
+IN: bootstrap.tools
{
"inspector"
diff --git a/basis/bootstrap/ui/ui.factor b/basis/bootstrap/ui/ui.factor
index 5aa7683efc..0cdf3137f6 100644
--- a/basis/bootstrap/ui/ui.factor
+++ b/basis/bootstrap/ui/ui.factor
@@ -1,5 +1,6 @@
USING: alien namespaces system combinators kernel sequences
vocabs vocabs.loader ;
+IN: bootstrap.ui
"bootstrap.compiler" vocab [
"ui-backend" get [
diff --git a/basis/bootstrap/unicode/unicode.factor b/basis/bootstrap/unicode/unicode.factor
index 3c65669ea7..1046d41bdc 100755
--- a/basis/bootstrap/unicode/unicode.factor
+++ b/basis/bootstrap/unicode/unicode.factor
@@ -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
diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor
new file mode 100644
index 0000000000..19427b7c79
--- /dev/null
+++ b/basis/calendar/calendar-docs.factor
@@ -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." } ;
diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index 0abc00b4a4..402542de3b 100755
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -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 ;
diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor
index e2b6a280ef..bfe438fae1 100755
--- a/basis/calendar/format/format.factor
+++ b/basis/calendar/format/format.factor
@@ -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
@@ -244,13 +244,13 @@ ERROR: invalid-timestamp-format ;
[ (ymdhms>timestamp) ] with-string-reader ;
: (hms>timestamp) ( -- timestamp )
- f f f read-hms instant <timestamp> ;
+ 0 0 0 read-hms instant <timestamp> ;
: hms>timestamp ( str -- timestamp )
[ (hms>timestamp) ] with-string-reader ;
: (ymd>timestamp) ( -- timestamp )
- read-ymd f f f instant <timestamp> ;
+ read-ymd 0 0 0 instant <timestamp> ;
: ymd>timestamp ( str -- timestamp )
[ (ymd>timestamp) ] with-string-reader ;
diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 94c5f05887..ea7280b5a6 100755
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -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
diff --git a/basis/compiler/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor
index e1b4e42e67..ae30502524 100755
--- a/basis/compiler/generator/fixup/fixup.factor
+++ b/basis/compiler/generator/fixup/fixup.factor
@@ -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 ;
diff --git a/basis/compiler/generator/iterator/iterator.factor b/basis/compiler/generator/iterator/iterator.factor
index 34a0cf149f..473d59c3e4 100644
--- a/basis/compiler/generator/iterator/iterator.factor
+++ b/basis/compiler/generator/iterator/iterator.factor
@@ -37,9 +37,9 @@ DEFER: (tail-call?)
: tail-call? ( -- ? )
node-stack get [
rest-slice
- dup [
+ dup empty? [ drop t ] [
[ (tail-call?) ]
[ first #terminate? not ]
bi and
- ] [ drop t ] if
+ ] if
] all? ;
diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor
index 41753433de..2452b19e11 100755
--- a/basis/compiler/generator/registers/registers.factor
+++ b/basis/compiler/generator/registers/registers.factor
@@ -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 -- )
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 6944849fcb..9d2b43c1df 100644
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -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
diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor
index 42becc5588..f5a1a86ae3 100755
--- a/basis/compiler/tests/intrinsics.factor
+++ b/basis/compiler/tests/intrinsics.factor
@@ -450,3 +450,14 @@ cell 8 = [
[ 8 ] [
1 [ 3 fixnum-shift-fast ] compile-call
] unit-test
+
+TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
+
+[ B{ 0 1 } ] [
+ B{ 0 0 } 1 alien-accessor-regression boa
+ dup [
+ { alien-accessor-regression } declare
+ [ i>> ] [ b>> ] bi over set-alien-unsigned-1
+ ] compile-call
+ b>>
+] unit-test
diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor
index 9f9a6e8e92..9f42ad201f 100755
--- a/basis/compiler/tests/optimizer.factor
+++ b/basis/compiler/tests/optimizer.factor
@@ -3,7 +3,7 @@ stack-checker kernel kernel.private math prettyprint sequences
sbufs strings tools.test vectors words sequences.private
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
-compiler.tree.builder compiler.tree.optimizer ;
+compiler.tree.builder compiler.tree.optimizer sequences.deep ;
IN: optimizer.tests
GENERIC: xyz ( obj -- obj )
@@ -353,3 +353,12 @@ TUPLE: some-tuple x ;
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
+
+: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
+
+[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
+[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
+
+[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
+
+[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor
index 2c667eaceb..2f21777801 100644
--- a/basis/compiler/tests/redefine4.factor
+++ b/basis/compiler/tests/redefine4.factor
@@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
-[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" print f ;" eval ] unit-test
+[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test
diff --git a/basis/compiler/tests/redefine5.factor b/basis/compiler/tests/redefine5.factor
new file mode 100644
index 0000000000..ac1619b857
--- /dev/null
+++ b/basis/compiler/tests/redefine5.factor
@@ -0,0 +1,32 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel ;
+IN: compiler.tests
+
+! Regression: if dispatch was eliminated but method was not inlined,
+! compiled usage information was not recorded.
+
+[ "compiler.tests.redefine5" forget-vocab ] with-compilation-unit
+
+[ ] [
+ <"
+ USING: sorting kernel math.order ;
+ IN: compiler.tests.redefine5
+ GENERIC: my-generic ( a -- b )
+ M: object my-generic [ <=> ] sort ;
+ : my-inline ( a -- b ) my-generic ;
+ "> eval
+] unit-test
+
+[ ] [
+ <"
+ USE: kernel
+ IN: compiler.tests.redefine5
+ TUPLE: my-tuple ;
+ M: my-tuple my-generic drop 0 ;
+ "> eval
+] unit-test
+
+[ 0 ] [
+ "my-tuple" "compiler.tests.redefine5" lookup boa
+ "my-inline" "compiler.tests.redefine5" lookup execute
+] unit-test
diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index 9feb931c03..003bd1cc69 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sequences.deep combinators fry
-classes.algebra namespaces assocs math math.private
-math.partial-dispatch classes.tuple classes.tuple.private
-definitions stack-checker.state stack-checker.branches
-compiler.tree
+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
compiler.tree.combinators
compiler.tree.propagation.info
@@ -51,9 +51,11 @@ GENERIC: cleanup* ( node -- node/nodes )
tri prefix ;
: cleanup-inlining ( #call -- nodes )
- [ dup method>> [ drop ] [ word>> +inlined+ depends-on ] if ]
- [ body>> cleanup ]
- bi ;
+ [
+ dup method>>
+ [ method>> dup word? [ +called+ depends-on ] [ drop ] if ]
+ [ word>> +inlined+ depends-on ] if
+ ] [ body>> cleanup ] bi ;
! Removing overflow checks
: no-overflow-variant ( op -- fast-op )
@@ -64,9 +66,19 @@ GENERIC: cleanup* ( node -- node/nodes )
{ fixnum-shift fixnum-shift-fast }
} at ;
+: (remove-overflow-check?) ( #call -- ? )
+ node-output-infos first class>> fixnum class<= ;
+
+: small-shift? ( #call -- ? )
+ node-input-infos second interval>>
+ cell-bits tag-bits get - [ neg ] keep [a,b] interval-subset? ;
+
: remove-overflow-check? ( #call -- ? )
- dup word>> no-overflow-variant
- [ node-output-infos first class>> fixnum class<= ] [ drop f ] if ;
+ {
+ { [ dup word>> \ fixnum-shift eq? ] [ [ (remove-overflow-check?) ] [ small-shift? ] bi and ] }
+ { [ dup word>> no-overflow-variant ] [ (remove-overflow-check?) ] }
+ [ drop f ]
+ } cond ;
: remove-overflow-check ( #call -- #call )
[ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
@@ -92,8 +104,11 @@ M: #declare cleanup* drop f ;
: fold-only-branch ( #branch -- node/nodes )
#! If only one branch is live we don't need to branch at
#! all; just drop the condition value.
- dup live-children sift dup length 1 =
- [ first swap in-d>> #drop prefix ] [ drop ] if ;
+ dup live-children sift dup length {
+ { 0 [ 2drop f ] }
+ { 1 [ first swap in-d>> #drop prefix ] }
+ [ 2drop ]
+ } case ;
SYMBOL: live-branches
@@ -108,15 +123,18 @@ M: #branch cleanup*
[ live-branches>> live-branches set ]
} cleave ;
+: output-fs ( values -- nodes )
+ [ f swap #push ] map ;
+
: eliminate-single-phi ( #phi -- node )
[ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
- [ [ drop ] [ [ f swap #push ] map ] bi* ]
+ [ [ drop ] [ output-fs ] bi* ]
[ #copy ]
if ;
: eliminate-phi ( #phi -- node )
live-branches get sift length {
- { 0 [ drop f ] }
+ { 0 [ out-d>> output-fs ] }
{ 1 [ eliminate-single-phi ] }
[ drop ]
} case ;
diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor
index 4c04ec3917..e8d2b29027 100644
--- a/basis/compiler/tree/dead-code/dead-code-tests.factor
+++ b/basis/compiler/tree/dead-code/dead-code-tests.factor
@@ -120,7 +120,7 @@ IN: compiler.tree.dead-code.tests
: call-recursive-dce-1 ( a -- b )
[ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
-[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [
+[ [ drop "WRAP" [ "REC" drop "REC" ] label ] ] [
[ call-recursive-dce-1 ] optimize-quot squish
] unit-test
@@ -134,7 +134,7 @@ IN: compiler.tree.dead-code.tests
[ f call-recursive-dce-2 drop ] optimize-quot squish
] unit-test
-[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [
+[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
[ f call-recursive-dce-2 ] optimize-quot squish
] unit-test
@@ -152,7 +152,7 @@ IN: compiler.tree.dead-code.tests
: call-recursive-dce-4 ( a -- b )
call-recursive-dce-4 ; inline recursive
-[ [ "WRAP" [ "REC" ] label ] ] [
+[ [ drop "WRAP" [ "REC" ] label ] ] [
[ call-recursive-dce-4 ] optimize-quot squish
] unit-test
@@ -182,3 +182,8 @@ IN: compiler.tree.dead-code.tests
[ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
[ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test
+
+: call-recursive-dce-7 ( obj -- elt ? )
+ dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive
+
+[ ] [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test
diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor
index 4c6b411430..03d4e919ee 100644
--- a/basis/compiler/tree/dead-code/recursive/recursive.factor
+++ b/basis/compiler/tree/dead-code/recursive/recursive.factor
@@ -13,11 +13,8 @@ M: #enter-recursive compute-live-values*
#! corresponding inputs to the #call-recursive are live also.
[ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
-: return-recursive-phi-in ( #return-recursive -- phi-in )
- [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
-
M: #return-recursive compute-live-values*
- [ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ;
+ [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
M: #call-recursive compute-live-values*
#! If the output of a #call-recursive is live, then the
@@ -34,15 +31,6 @@ M: #call-recursive compute-live-values*
drop-values
] ;
-M: #recursive remove-dead-code* ( node -- nodes )
- dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
- {
- [ [ dup label>> enter-recursive>> ] [ out-d>> ] bi* '[ , >>in-d drop ] bi@ ]
- [ drop [ (remove-dead-code) ] change-child drop ]
- [ drop label>> [ filter-live ] change-enter-out drop ]
- [ swap 2array ]
- } 2cleave ;
-
M: #enter-recursive remove-dead-code*
[ filter-live ] change-out-d ;
@@ -73,9 +61,30 @@ M: #call-recursive remove-dead-code*
[ drop-call-recursive-outputs ]
tri 3array ;
-M: #return-recursive remove-dead-code* ( node -- nodes )
- dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs
- [ drop [ filter-live ] change-out-d drop ]
- [ out-d>> >>in-d drop ]
- [ swap 2array ]
- 2tri ;
+:: drop-recursive-inputs ( node -- shuffle )
+ [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
+ new-outputs [ shuffle out-d>> ] |
+ node new-outputs
+ [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
+ shuffle
+ ] ;
+
+:: drop-recursive-outputs ( node -- shuffle )
+ [let* | return [ node label>> return>> ]
+ new-inputs [ return in-d>> filter-live ]
+ new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
+ return
+ [ new-inputs >>in-d new-outputs >>out-d drop ]
+ [ drop-dead-outputs ]
+ bi
+ ] ;
+
+M:: #recursive remove-dead-code* ( node -- nodes )
+ [let* | drop-inputs [ node drop-recursive-inputs ]
+ drop-outputs [ node drop-recursive-outputs ] |
+ node [ (remove-dead-code) ] change-child drop
+ node label>> [ filter-live ] change-enter-out drop
+ drop-inputs node drop-outputs 3array
+ ] ;
+
+M: #return-recursive remove-dead-code* ;
diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor
index f1be869295..2bcf91e6ab 100644
--- a/basis/compiler/tree/dead-code/simple/simple.factor
+++ b/basis/compiler/tree/dead-code/simple/simple.factor
@@ -1,7 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors words assocs sequences arrays namespaces
-fry locals classes.algebra stack-checker.backend
+fry locals definitions classes.algebra
+stack-checker.state
+stack-checker.backend
compiler.tree
compiler.tree.propagation.info
compiler.tree.dead-code.liveness ;
@@ -80,11 +82,10 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
] ;
: drop-dead-outputs ( node -- nodes )
- dup out-d>> drop-dead-values
- [ in-d>> >>out-d drop ] [ 2array ] 2bi ;
+ dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
M: #introduce remove-dead-code* ( #introduce -- nodes )
- drop-dead-outputs ;
+ dup drop-dead-outputs 2array ;
M: #>r remove-dead-code*
[ filter-live ] change-out-r
@@ -105,7 +106,9 @@ M: #push remove-dead-code*
] [ drop f ] if ;
: remove-flushable-call ( #call -- node )
- in-d>> #drop remove-dead-code* ;
+ [ word>> +inlined+ depends-on ]
+ [ in-d>> #drop remove-dead-code* ]
+ bi ;
: some-outputs-dead? ( #call -- ? )
out-d>> [ live-value? not ] contains? ;
@@ -115,7 +118,7 @@ M: #call remove-dead-code*
remove-flushable-call
] [
dup some-outputs-dead? [
- drop-dead-outputs
+ dup drop-dead-outputs 2array
] when
] if ;
diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 9267df93ed..0b7db5b36a 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -7,7 +7,7 @@ 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
-stack-checker.errors ;
+stack-checker.errors kernel.private ;
\ escape-analysis must-infer
@@ -316,3 +316,7 @@ C: <ro-box> ro-box
[ \ too-many->r boa f f \ inference-error boa ]
count-unboxed-allocations
] unit-test
+
+[ 0 ] [
+ [ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
+] unit-test
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index b30800b445..e01d12ac23 100644
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -125,21 +125,20 @@ SYMBOL: history
: remember-inlining ( word -- )
history [ swap suffix ] change ;
-: inline-word ( #call word -- )
+: inline-word ( #call word -- ? )
dup history get memq? [
- 2drop
+ 2drop f
] [
[
dup remember-inlining
dupd def>> splicing-nodes >>body
propagate-body
] with-scope
+ t
] if ;
: inline-method-body ( #call word -- ? )
- 2dup should-inline? [ inline-word t ] [ 2drop f ] if ;
+ 2dup should-inline? [ inline-word ] [ 2drop f ] if ;
: always-inline-word? ( word -- ? )
{ curry compose } memq? ;
-
-: always-inline-word ( #call word -- ? ) inline-word t ;
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index da68503c1e..503c633077 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -571,6 +571,8 @@ MIXIN: empty-mixin
[ ] [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test
+[ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor
index 528829ff4d..48a4b478e6 100644
--- a/basis/compiler/tree/propagation/simple/simple.factor
+++ b/basis/compiler/tree/propagation/simple/simple.factor
@@ -93,7 +93,7 @@ M: #declare propagate-before
: do-inlining ( #call word -- ? )
{
- { [ dup always-inline-word? ] [ always-inline-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 ] }
diff --git a/basis/concurrency/futures/futures.factor b/basis/concurrency/futures/futures.factor
index 85f1ba44a0..132342aff1 100755
--- a/basis/concurrency/futures/futures.factor
+++ b/basis/concurrency/futures/futures.factor
@@ -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 )
diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor
index 659bd2714e..92dede1655 100755
--- a/basis/concurrency/locks/locks-tests.factor
+++ b/basis/concurrency/locks/locks-tests.factor
@@ -1,7 +1,7 @@
IN: concurrency.locks.tests
USING: tools.test concurrency.locks concurrency.count-downs
concurrency.messaging concurrency.mailboxes locals kernel
-threads sequences calendar ;
+threads sequences calendar accessors ;
:: lock-test-0 ( -- )
[let | v [ V{ } clone ]
@@ -174,7 +174,7 @@ threads sequences calendar ;
] ;
[ lock-timeout-test ] [
- linked-error-thread thread-name "Lock timeout-er" =
+ linked-error-thread name>> "Lock timeout-er" =
] must-fail-with
:: read/write-test ( -- )
diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor
index e77760408c..12b5d270d4 100755
--- a/basis/concurrency/messaging/messaging.factor
+++ b/basis/concurrency/messaging/messaging.factor
@@ -4,14 +4,14 @@
! 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 -- )
: mailbox-of ( thread -- mailbox )
- dup thread-mailbox [ ] [
- <mailbox> dup rot set-thread-mailbox
+ dup mailbox>> [ ] [
+ <mailbox> [ >>mailbox drop ] keep
] ?if ;
M: thread send ( message thread -- )
@@ -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
diff --git a/basis/concurrency/promises/promises.factor b/basis/concurrency/promises/promises.factor
index b432d63bfc..511decdf35 100755
--- a/basis/concurrency/promises/promises.factor
+++ b/basis/concurrency/promises/promises.factor
@@ -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 ;
diff --git a/basis/concurrency/semaphores/semaphores.factor b/basis/concurrency/semaphores/semaphores.factor
index 8b88c540bc..1b55c7afa5 100755
--- a/basis/concurrency/semaphores/semaphores.factor
+++ b/basis/concurrency/semaphores/semaphores.factor
@@ -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
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 4528eb3edc..0ba3b93730 100755
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -3,7 +3,7 @@
USING: accessors alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
-namespaces sequences compiler.generator.registers
+namespaces sequences compiler.generator compiler.generator.registers
compiler.generator.fixup system layouts alien alien.accessors
alien.structs slots splitting assocs ;
IN: cpu.x86.64
diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor
index 203fe7ac67..536b914f39 100755
--- a/basis/cpu/x86/intrinsics/intrinsics.factor
+++ b/basis/cpu/x86/intrinsics/intrinsics.factor
@@ -404,10 +404,8 @@ IN: cpu.x86.intrinsics
: %alien-integer-set ( quot reg -- )
small-reg PUSH
- "offset" get "value" get = [
- "value" operand %untag-fixnum
- ] unless
small-reg "value" operand MOV
+ small-reg %untag-fixnum
swap %alien-accessor
small-reg POP ; inline
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index eacbd6a125..51ef806ebe 100755
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -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 ;
@@ -44,7 +44,7 @@ M: string error. print ;
: restart. ( restart n -- )
[
1+ dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
- restart-name %
+ name>> %
] "" make print ;
: restarts. ( -- )
diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor
index d046102ec9..2eb2cc2762 100755
--- a/basis/documents/documents.factor
+++ b/basis/documents/documents.factor
@@ -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 ;
diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor
index 61ebe744f8..28eea4701e 100755
--- a/basis/float-arrays/float-arrays.factor
+++ b/basis/float-arrays/float-arrays.factor
@@ -58,8 +58,7 @@ INSTANCE: float-array sequence
: 4float-array ( w x y z -- array )
T{ float-array } 4sequence ; inline
-: F{ ( parsed -- parsed )
- \ } [ >float-array ] parse-literal ; parsing
+: F{ \ } [ >float-array ] parse-literal ; parsing
M: float-array pprint-delims drop \ F{ \ } ;
diff --git a/basis/heaps/heaps-tests.factor b/basis/heaps/heaps-tests.factor
index d55b547b8f..13b6a97654 100755
--- a/basis/heaps/heaps-tests.factor
+++ b/basis/heaps/heaps-tests.factor
@@ -48,7 +48,7 @@ IN: heaps.tests
: test-entry-indices ( n -- ? )
random-alist
<min-heap> [ heap-push-all ] keep
- data>> dup length swap [ entry-index ] map sequence= ;
+ data>> dup length swap [ index>> ] map sequence= ;
14 [
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
@@ -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 [
diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor
index 1873db67b5..21eab2b8f1 100755
--- a/basis/heaps/heaps.factor
+++ b/basis/heaps/heaps.factor
@@ -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
diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor
index 6ad3b23c2c..14a6c3f8ad 100755
--- a/basis/help/topics/topics.factor
+++ b/basis/help/topics/topics.factor
@@ -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 ;
diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor
index 7d7af5d4fd..c8fb7d365a 100755
--- a/basis/inspector/inspector.factor
+++ b/basis/inspector/inspector.factor
@@ -72,7 +72,7 @@ M: tuple error. describe ;
namestack namestack. ;
: :vars ( -- )
- error-continuation get continuation-name namestack. ;
+ error-continuation get name>> namestack. ;
SYMBOL: inspector-hook
diff --git a/basis/io/buffers/buffers-docs.factor b/basis/io/buffers/buffers-docs.factor
index 266c0d64f1..fbe352185c 100755
--- a/basis/io/buffers/buffers-docs.factor
+++ b/basis/io/buffers/buffers-docs.factor
@@ -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>
diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor
index 09f240c53a..1b22ca8501 100755
--- a/basis/io/launcher/launcher.factor
+++ b/basis/io/launcher/launcher.factor
@@ -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 ;
diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor
index fa0e2f515d..1ed83956c3 100755
--- a/basis/io/servers/connection/connection.factor
+++ b/basis/io/servers/connection/connection.factor
@@ -41,7 +41,7 @@ ready ;
SYMBOL: remote-address
-GENERIC: handle-client* ( server -- )
+GENERIC: handle-client* ( threaded-server -- )
<PRIVATE
@@ -75,21 +75,21 @@ M: threaded-server handle-client* handler>> call ;
: thread-name ( server-name addrspec -- string )
unparse " connection from " swap 3append ;
-: accept-connection ( server -- )
+: accept-connection ( threaded-server -- )
[ accept ] [ addr>> ] bi
[ '[ , , , handle-client ] ]
[ drop threaded-server get name>> swap thread-name ] 2bi
spawn drop ;
-: accept-loop ( server -- )
+: accept-loop ( threaded-server -- )
[
threaded-server get semaphore>>
[ [ accept-connection ] with-semaphore ]
[ accept-connection ]
if*
- ] [ accept-loop ] bi ; inline
+ ] [ accept-loop ] bi ; inline recursive
-: started-accept-loop ( server -- )
+: started-accept-loop ( threaded-server -- )
threaded-server get
[ sockets>> push ] [ ready>> raise-flag ] bi ;
diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor
index 979ac3dc21..3c77be254c 100755
--- a/basis/io/sockets/sockets-docs.factor
+++ b/basis/io/sockets/sockets-docs.factor
@@ -62,7 +62,7 @@ ARTICLE: "network-streams" "Networking"
ABOUT: "network-streams"
HELP: local
-{ $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $link local-path } " slot holds the path name of the socket. New instances are created by calling " { $link <local> } "." }
+{ $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $snippet "path" } " slot holds the path name of the socket. New instances are created by calling " { $link <local> } "." }
{ $examples
{ $code "\"/tmp/.X11-unix/0\" <local>" }
} ;
diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor
index 752f413458..b0eb327927 100644
--- a/basis/io/styles/styles.factor
+++ b/basis/io/styles/styles.factor
@@ -1,8 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-
USING: hashtables io colors ;
-
IN: io.styles
SYMBOL: plain
diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
index a0b667e44b..3ba52ea391 100755
--- a/basis/locals/locals.factor
+++ b/basis/locals/locals.factor
@@ -75,7 +75,7 @@ TUPLE: quote local ;
C: <quote> quote
: local-index ( obj args -- n )
- [ dup quote? [ quote-local ] when eq? ] with find drop ;
+ [ dup quote? [ local>> ] when eq? ] with find drop ;
: read-local-quot ( obj args -- quot )
local-index 1+ [ get-local ] curry ;
@@ -87,7 +87,7 @@ C: <quote> quote
: localize ( obj args -- quot )
{
{ [ over local? ] [ read-local-quot ] }
- { [ over quote? ] [ >r quote-local r> read-local-quot ] }
+ { [ over quote? ] [ >r local>> r> read-local-quot ] }
{ [ over local-word? ] [ read-local-quot [ call ] append ] }
{ [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
{ [ over local-writer? ] [ localize-writer ] }
@@ -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*
diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor
index e8cd9d1d19..0a6621f044 100755
--- a/basis/macros/macros.factor
+++ b/basis/macros/macros.factor
@@ -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 ;
diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor
index b5cd231402..c5e5a6e7b8 100644
--- a/basis/math/intervals/intervals-docs.factor
+++ b/basis/math/intervals/intervals-docs.factor
@@ -88,7 +88,7 @@ ABOUT: "math-intervals"
HELP: interval
{ $class-description "An interval represents a set of real numbers between two endpoints; the endpoints can either be included or excluded from the interval."
$nl
-"The " { $link interval-from } " and " { $link interval-to } " slots store endpoints, represented as arrays of the shape " { $snippet "{ number included? }" } "."
+"The " { $snippet "from" } " and " { $snippet "to" } " slots store endpoints, represented as arrays of the shape " { $snippet "{ number included? }" } "."
$nl
"Intervals are created by calling " { $link [a,b] } ", " { $link (a,b) } ", " { $link [a,b) } ", " { $link (a,b] } " or " { $link [a,a] } "." } ;
diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor
index 9a71832133..4b1a4a67d5 100755
--- a/basis/memoize/memoize.factor
+++ b/basis/memoize/memoize.factor
@@ -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
diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor
index 641fce6efc..ce99314ce6 100755
--- a/basis/mirrors/mirrors.factor
+++ b/basis/mirrors/mirrors.factor
@@ -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
diff --git a/basis/models/models.factor b/basis/models/models.factor
index 94b47dc4db..45519f7021 100755
--- a/basis/models/models.factor
+++ b/basis/models/models.factor
@@ -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 )
diff --git a/basis/opengl/opengl-docs.factor b/basis/opengl/opengl-docs.factor
index ba815afb55..87981789a7 100644
--- a/basis/opengl/opengl-docs.factor
+++ b/basis/opengl/opengl-docs.factor
@@ -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" }
+ { { $snippet "dlist" } " - an OpenGL display list ID" }
+ { { $snippet "texture" } " - an OpenGL texture ID" }
+ { { $snippet "loc" } " - top-left corner of the sprite" }
+ { { $snippet "dim" } " - dimensions of the sprite" }
+ { { $snippet "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 } }
diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index 29c2e5400a..2d1b644050 100755
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -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 ;
diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor
index b5b2886a5e..6342deb79e 100755
--- a/basis/peg/parsers/parsers.factor
+++ b/basis/peg/parsers/parsers.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
- vectors arrays math.parser
+ vectors arrays math.parser accessors
unicode.categories sequences.deep peg peg.private
peg.search math.ranges words ;
IN: peg.parsers
@@ -11,7 +11,7 @@ TUPLE: just-parser p1 ;
: just-pattern
[
execute dup [
- dup parse-result-remaining empty? [ drop f ] unless
+ dup remaining>> empty? [ drop f ] unless
] when
] ;
diff --git a/basis/persistent/heaps/heaps-docs.factor b/basis/persistent/heaps/heaps-docs.factor
index dbfadc4ed2..a56022a039 100644
--- a/basis/persistent/heaps/heaps-docs.factor
+++ b/basis/persistent/heaps/heaps-docs.factor
@@ -38,7 +38,7 @@ HELP: pheap>alist
{ $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ;
HELP: pheap>values
-{ $values { "heap" "a persistent heap" } { "values" array } }
+{ $values { "heap" "a persistent heap" } { "seq" array } }
{ $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ;
ARTICLE: "persistent-heaps" "Persistent heaps"
diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor
index 534ab0fd09..6ad883cfcb 100755
--- a/basis/prettyprint/prettyprint-tests.factor
+++ b/basis/prettyprint/prettyprint-tests.factor
@@ -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 ] [
diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor
new file mode 100644
index 0000000000..e30b3fcc27
--- /dev/null
+++ b/basis/smtp/smtp-docs.factor
@@ -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 ;
diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor
index 7cc0e7efbb..f8b321fdac 100755
--- a/basis/smtp/smtp-tests.factor
+++ b/basis/smtp/smtp-tests.factor
@@ -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
diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor
index 63a37acf36..5df4b80614 100755
--- a/basis/smtp/smtp.factor
+++ b/basis/smtp/smtp.factor
@@ -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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor
index e373d36124..6523598cff 100644
--- a/basis/stack-checker/inlining/inlining.factor
+++ b/basis/stack-checker/inlining/inlining.factor
@@ -67,8 +67,10 @@ SYMBOL: enter-out
[ entry-stack-height current-stack-height swap - ]
bi*
= [ 2drop ] [
- word>> current-stack-height
- unbalanced-recursion-error inference-error
+ terminated? get [ 2drop ] [
+ word>> current-stack-height
+ unbalanced-recursion-error inference-error
+ ] if
] if ;
: end-recursive-word ( word label -- )
@@ -79,7 +81,7 @@ SYMBOL: enter-out
: recursive-word-inputs ( label -- n )
entry-stack-height d-in get + ;
-: (inline-recursive-word) ( word -- label in out visitor )
+: (inline-recursive-word) ( word -- label in out visitor terminated? )
dup prepare-stack
[
init-inference
@@ -96,11 +98,13 @@ SYMBOL: enter-out
dup recursive-word-inputs
meta-d get
stack-visitor get
+ terminated? get
] with-scope ;
: inline-recursive-word ( word -- )
(inline-recursive-word)
- [ consume-d ] [ output-d ] [ ] tri* #recursive, ;
+ [ [ consume-d ] [ output-d ] [ ] tri* #recursive, ] dip
+ [ terminate ] when ;
: check-call-height ( label -- )
dup entry-stack-height current-stack-height >
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index e1da525f92..11e7a0d7fd 100755
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -331,7 +331,7 @@ SYMBOL: +primitive+
\ bignum-bitnot { bignum } { bignum } define-primitive
\ bignum-bitnot make-foldable
-\ bignum-shift { bignum bignum } { bignum } define-primitive
+\ bignum-shift { bignum fixnum } { bignum } define-primitive
\ bignum-shift make-foldable
\ bignum< { bignum bignum } { object } define-primitive
diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index b78e1b5729..dc049ee1a4 100755
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -575,3 +575,8 @@ DEFER: eee'
: eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive
[ [ eee' ] infer ] [ inference-error? ] must-fail-with
+
+: bogus-error ( x -- )
+ dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
+
+[ bogus-error ] must-infer
diff --git a/basis/state-parser/state-parser.factor b/basis/state-parser/state-parser.factor
index 0aec1280de..ee5a5113bf 100644
--- a/basis/state-parser/state-parser.factor
+++ b/basis/state-parser/state-parser.factor
@@ -88,13 +88,12 @@ SYMBOL: prolog-data
: next* ( -- )
get-char [ (next) record ] when ;
-: skip-until ( quot -- )
- #! quot: ( -- ? )
+: skip-until ( quot: ( -- ? ) -- )
get-char [
[ call ] keep swap [ drop ] [
next skip-until
] if
- ] [ drop ] if ; inline
+ ] [ drop ] if ; inline recursive
: take-until ( quot -- string )
#! Take the substring of a string starting at spot
diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor
index da308f5abf..3c4715d3e3 100755
--- a/basis/threads/threads-docs.factor
+++ b/basis/threads/threads-docs.factor
@@ -38,7 +38,7 @@ ARTICLE: "thread-state" "Thread-local state and variables"
{ $subsection tchange }
"Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set."
$nl
-"Global hashtable of all threads, keyed by " { $link thread-id } ":"
+"Global hashtable of all threads, keyed by " { $snippet "id" } ":"
{ $subsection threads }
"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
@@ -63,10 +63,10 @@ ABOUT: "threads"
HELP: thread
{ $class-description "A thread. The slots are as follows:"
{ $list
- { { $link thread-id } " - a unique identifier assigned to each thread." }
- { { $link thread-name } " - the name passed to " { $link spawn } "." }
- { { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." }
- { { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
+ { { $snippet "id" } " - a unique identifier assigned to each thread." }
+ { { $snippet "name" } " - the name passed to " { $link spawn } "." }
+ { { $snippet "quot" } " - the initial quotation passed to " { $link spawn } "." }
+ { { $snippet "continuation" } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
}
} ;
diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
index 023993c435..96c2ec2fcc 100755
--- a/basis/tools/annotations/annotations.factor
+++ b/basis/tools/annotations/annotations.factor
@@ -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 ;
diff --git a/basis/tools/threads/threads.factor b/basis/tools/threads/threads.factor
index 2bd38cf304..1b75e46e25 100755
--- a/basis/tools/threads/threads.factor
+++ b/basis/tools/threads/threads.factor
@@ -2,19 +2,19 @@
! See http://factorcode.org/license.txt for BSD license.
USING: threads kernel prettyprint prettyprint.config
io io.styles sequences assocs namespaces sorting boxes
-heaps.private system math math.parser math.order ;
+heaps.private system math math.parser math.order accessors ;
IN: tools.threads
: thread. ( thread -- )
- dup thread-id pprint-cell
- dup thread-name over [ write-object ] with-cell
- dup thread-state [
+ dup id>> pprint-cell
+ dup name>> over [ write-object ] with-cell
+ dup state>> [
[ dup self eq? "running" "yield" ? ] unless*
write
] with-cell
[
- thread-sleep-entry [
- entry-key millis [-] number>string write
+ sleep-entry>> [
+ key>> millis [-] number>string write
" ms" write
] when*
] with-cell ;
diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor
index 6328a3d06d..08eb3d7c32 100755
--- a/basis/tools/vocabs/vocabs.factor
+++ b/basis/tools/vocabs/vocabs.factor
@@ -4,7 +4,7 @@ USING: kernel io io.styles io.files io.encodings.utf8
vocabs.loader vocabs sequences namespaces math.parser arrays
hashtables assocs memoize summary sorting splitting combinators
source-files debugger continuations compiler.errors init
-checksums checksums.crc32 sets ;
+checksums checksums.crc32 sets accessors ;
IN: tools.vocabs
: vocab-tests-file ( vocab -- path )
@@ -61,10 +61,10 @@ SYMBOL: failures
: source-modified? ( path -- ? )
dup source-files get at [
- dup source-file-path
+ dup path>>
dup exists? [
utf8 file-lines crc32 checksum-lines
- swap source-file-checksum = not
+ swap checksum>> = not
] [
2drop f
] if
@@ -175,7 +175,7 @@ M: vocab summary
[
dup vocab-summary %
" (" %
- vocab-words assoc-size #
+ words>> assoc-size #
" words)" %
] "" make ;
diff --git a/basis/tools/walker/debug/debug.factor b/basis/tools/walker/debug/debug.factor
index 1fded308b4..2b252404d6 100755
--- a/basis/tools/walker/debug/debug.factor
+++ b/basis/tools/walker/debug/debug.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises models tools.walker kernel
sequences concurrency.messaging locals continuations
-threads namespaces namespaces.private assocs ;
+threads namespaces namespaces.private assocs accessors ;
IN: tools.walker.debug
:: test-walker ( quot -- data )
@@ -26,6 +26,6 @@ IN: tools.walker.debug
send-synchronous drop
p ?promise
- thread-variables walker-continuation swap at
- model-value continuation-data
+ variables>> walker-continuation swap at
+ model-value data>>
] ;
diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor
index f9055fb6cf..cb5283e797 100755
--- a/basis/tools/walker/walker.factor
+++ b/basis/tools/walker/walker.factor
@@ -22,8 +22,8 @@ DEFER: start-walker-thread
: get-walker-thread ( -- status continuation thread )
walker-thread tget [
- [ thread-variables walker-status swap at ]
- [ thread-variables walker-continuation swap at ]
+ [ variables>> walker-status swap at ]
+ [ variables>> walker-continuation swap at ]
[ ] tri
] [
f <model>
@@ -43,7 +43,7 @@ DEFER: start-walker-thread
} cond ;
: break ( -- )
- continuation callstack over set-continuation-call
+ continuation callstack >>call
show-walker send-synchronous
after-break ;
@@ -248,7 +248,7 @@ SYMBOL: +stopped+
: associate-thread ( walker -- )
walker-thread tset
[ f walker-thread tget send-synchronous drop ]
- self set-thread-exit-handler ;
+ self (>>exit-handler) ;
: start-walker-thread ( status continuation -- thread' )
self [
@@ -258,7 +258,7 @@ SYMBOL: +stopped+
V{ } clone walker-history tset
walker-loop
] 3curry
- "Walker on " self thread-name append spawn
+ "Walker on " self name>> append spawn
[ associate-thread ] keep ;
! For convenience
diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor
index f0f8b4821c..0234a959da 100755
--- a/basis/unicode/case/case.factor
+++ b/basis/unicode/case/case.factor
@@ -1,6 +1,6 @@
USING: unicode.data sequences sequences.next namespaces
unicode.normalize math unicode.categories combinators
-assocs strings splitting kernel ;
+assocs strings splitting kernel accessors ;
IN: unicode.case
: at-default ( key assoc -- value/key ) over >r at r> or ;
@@ -91,17 +91,17 @@ SYMBOL: locale ! Just casing locale, or overall?
: >lower ( string -- lower )
i-dot? [ turk>lower ] when
- final-sigma [ code-point-lower ] [ ch>lower ] map-case ;
+ final-sigma [ lower>> ] [ ch>lower ] map-case ;
: >upper ( string -- upper )
i-dot? [ turk>upper ] when
- [ code-point-upper ] [ ch>upper ] map-case ;
+ [ upper>> ] [ ch>upper ] map-case ;
: >title ( string -- title )
final-sigma
CHAR: \s swap
[ tuck word-boundary swapd
- [ code-point-title ] [ code-point-lower ] if ]
+ [ title>> ] [ lower>> ] if ]
[ tuck word-boundary swapd
[ ch>title ] [ ch>lower ] if ]
map-case nip ;
diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor
index 124840a7fb..6f36461d38 100755
--- a/basis/unicode/normalize/normalize.factor
+++ b/basis/unicode/normalize/normalize.factor
@@ -1,5 +1,5 @@
USING: sequences namespaces unicode.data kernel math arrays
-locals sorting.insertion ;
+locals sorting.insertion accessors ;
IN: unicode.normalize
! Conjoining Jamo behavior
@@ -43,7 +43,7 @@ IN: unicode.normalize
: reorder-next ( string i -- new-i done? )
over [ non-starter? ] find-from drop [
reorder-slice
- >r dup [ combining-class ] insertion-sort slice-to r>
+ >r dup [ combining-class ] insertion-sort to>> r>
] [ length t ] if* ;
: reorder-loop ( string start -- )
diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor
index 4b96d13316..ade9b34d93 100755
--- a/basis/xml-rpc/xml-rpc.factor
+++ b/basis/xml-rpc/xml-rpc.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel xml arrays math generic http.client combinators
- hashtables namespaces io base64 sequences strings calendar
- xml.data xml.writer xml.utilities assocs math.parser debugger
- calendar.format math.order ;
+USING: accessors kernel xml arrays math generic http.client
+combinators hashtables namespaces io base64 sequences strings
+calendar xml.data xml.writer xml.utilities assocs math.parser
+debugger calendar.format math.order ;
IN: xml-rpc
! * Sending RPC requests
@@ -17,7 +17,7 @@ M: integer item>xml
[ "Integers must fit in 32 bits" throw ] unless
number>string "i4" build-tag ;
-PREDICATE: boolean < object { t f } member? ;
+UNION: boolean t POSTPONE: f ;
M: boolean item>xml
"1" "0" ? "boolean" build-tag ;
@@ -147,10 +147,10 @@ TAG: array xml>item
xml>item [ "faultCode" get "faultString" get ] bind ;
: receive-rpc ( xml -- rpc )
- dup name-tag dup "methodCall" =
+ dup main>> dup "methodCall" =
[ drop parse-method <rpc-method> ] [
"methodResponse" = [
- dup first-child-tag name-tag "fault" =
+ dup first-child-tag main>> "fault" =
[ parse-fault <rpc-fault> ]
[ parse-rpc-response <rpc-response> ] if
] [ "Bad main tag name" server-error ] if
diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor
index da2e4ccb32..1bab8d0374 100755
--- a/basis/xml/data/data.factor
+++ b/basis/xml/data/data.factor
@@ -1,25 +1,26 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private assocs arrays
-delegate.protocols delegate vectors ;
+delegate.protocols delegate vectors accessors multiline
+macros words quotations combinators ;
IN: xml.data
-TUPLE: name space tag url ;
+TUPLE: name space main url ;
C: <name> name
: ?= ( object/f object/f -- ? )
2dup and [ = ] [ 2drop t ] if ;
: names-match? ( name1 name2 -- ? )
- [ name-space swap name-space ?= ] 2keep
- [ name-url swap name-url ?= ] 2keep
- name-tag swap name-tag ?= and and ;
+ [ [ space>> ] bi@ ?= ]
+ [ [ url>> ] bi@ ?= ]
+ [ [ main>> ] bi@ ?= ] 2tri and and ;
-: <name-tag> ( string -- name )
+: <simple-name> ( string -- name )
f swap f <name> ;
: assure-name ( string/name -- name )
- dup name? [ <name-tag> ] unless ;
+ dup name? [ <simple-name> ] unless ;
TUPLE: opener name attrs ;
C: <opener> opener
@@ -42,13 +43,11 @@ C: <instruction> instruction
TUPLE: prolog version encoding standalone ;
C: <prolog> prolog
-TUPLE: tag attrs children ;
-
TUPLE: attrs alist ;
C: <attrs> attrs
: attr@ ( key alist -- index {key,value} )
- >r assure-name r> attrs-alist
+ >r assure-name r> alist>>
[ first names-match? ] with find ;
M: attrs at*
@@ -58,12 +57,12 @@ M: attrs set-at
2nip set-second
] [
>r assure-name swap 2array r>
- [ attrs-alist ?push ] keep set-attrs-alist
+ [ alist>> ?push ] keep (>>alist)
] if* ;
-M: attrs assoc-size attrs-alist length ;
+M: attrs assoc-size alist>> length ;
M: attrs new-assoc drop V{ } new-sequence <attrs> ;
-M: attrs >alist attrs-alist ;
+M: attrs >alist alist>> ;
: >attrs ( assoc -- attrs )
dup [
@@ -74,61 +73,71 @@ M: attrs assoc-like
drop dup attrs? [ >attrs ] unless ;
M: attrs clear-assoc
- f swap set-attrs-alist ;
+ f >>alist drop ;
M: attrs delete-at
- tuck attr@ drop [ swap attrs-alist delete-nth ] [ drop ] if* ;
+ tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
M: attrs clone
- attrs-alist clone <attrs> ;
+ alist>> clone <attrs> ;
INSTANCE: attrs assoc
+TUPLE: tag name attrs children ;
+
: <tag> ( name attrs children -- tag )
- >r >r assure-name r> T{ attrs } assoc-like r>
- { set-delegate set-tag-attrs set-tag-children }
- tag construct ;
+ [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
+ tag boa ;
! For convenience, tags follow the assoc protocol too (for attrs)
CONSULT: assoc-protocol tag tag-attrs ;
INSTANCE: tag assoc
! They also follow the sequence protocol (for children)
-CONSULT: sequence-protocol tag tag-children ;
+CONSULT: sequence-protocol tag children>> ;
INSTANCE: tag sequence
+CONSULT: name tag name>> ;
+
M: tag like
over tag? [ drop ] [
- [ delegate ] keep tag-attrs
+ [ name>> ] keep tag-attrs
rot dup [ V{ } like ] when <tag>
] if ;
+MACRO: clone-slots ( class -- tuple )
+ [
+ "slots" word-prop
+ [ reader>> 1quotation [ clone ] compose ] map
+ [ cleave ] curry
+ ] [ [ boa ] curry ] bi compose ;
+
M: tag clone
- [ delegate clone ] keep [ tag-attrs clone ] keep
- tag-children clone
- { set-delegate set-tag-attrs set-tag-children } tag construct ;
+ tag clone-slots ;
-TUPLE: xml prolog before main after ;
-: <xml> ( prolog before main after -- xml )
- { set-xml-prolog set-xml-before set-delegate set-xml-after }
- xml construct ;
+TUPLE: xml prolog before body after ;
+C: <xml> xml
-CONSULT: sequence-protocol xml delegate ;
+CONSULT: sequence-protocol xml body>> ;
INSTANCE: xml sequence
-CONSULT: assoc-protocol xml delegate ;
+CONSULT: assoc-protocol xml body>> ;
INSTANCE: xml assoc
+CONSULT: tag xml body>> ;
+
+CONSULT: name xml body>> ;
+
<PRIVATE
: tag>xml ( xml tag -- newxml )
- swap [ dup xml-prolog swap xml-before rot ] keep xml-after <xml> ;
+ >r [ prolog>> ] [ before>> ] [ after>> ] tri r>
+ swap <xml> ;
: seq>xml ( xml seq -- newxml )
- over delegate like tag>xml ;
+ over body>> like tag>xml ;
PRIVATE>
M: xml clone
- [ xml-prolog clone ] keep [ xml-before clone ] keep
- [ delegate clone ] keep xml-after clone <xml> ;
+ xml clone-slots ;
M: xml like
swap dup xml? [ nip ] [
@@ -139,5 +148,5 @@ M: xml like
: <contained-tag> ( name attrs -- tag )
f <tag> ;
-PREDICATE: contained-tag < tag tag-children not ;
-PREDICATE: open-tag < tag tag-children ;
+PREDICATE: contained-tag < tag children>> not ;
+PREDICATE: open-tag < tag children>> ;
diff --git a/basis/xml/generator/generator.factor b/basis/xml/generator/generator.factor
index bf4bd618b7..d5cf4dac40 100644
--- a/basis/xml/generator/generator.factor
+++ b/basis/xml/generator/generator.factor
@@ -27,7 +27,7 @@ IN: xml.generator
! Word-based XML literal syntax
: parsed-name ( accum -- accum )
- scan ":" split1 [ f <name> ] [ <name-tag> ] if* parsed ;
+ scan ":" split1 [ f <name> ] [ <simple-name> ] if* parsed ;
: run-combinator ( accum quot1 quot2 -- accum )
>r [ ] like parsed r> [ parsed ] each ;
diff --git a/basis/xml/tests/templating.factor b/basis/xml/tests/templating.factor
index d81e807fe5..e95dad6618 100644
--- a/basis/xml/tests/templating.factor
+++ b/basis/xml/tests/templating.factor
@@ -1,5 +1,5 @@
USING: kernel xml sequences assocs tools.test io arrays namespaces
- xml.data xml.utilities xml.writer generic sequences.deep ;
+accessors xml.data xml.utilities xml.writer generic sequences.deep ;
IN: xml.tests
: sub-tag
@@ -11,7 +11,7 @@ GENERIC: (r-ref) ( xml -- )
M: tag (r-ref)
sub-tag over at* [
ref-table get at
- swap set-tag-children
+ >>children drop
] [ 2drop ] if ;
M: object (r-ref) drop ;
@@ -34,7 +34,7 @@ M: object (r-ref) drop ;
[
H{
{ "foo" { "foo" } }
- { "bar" { "blah" T{ tag T{ name f "" "a" "" } V{ } f } } }
+ { "bar" { "blah" T{ tag f T{ name f "" "a" "" } f f } } }
{ "baz" f }
} ref-table set
sample-doc string>xml dup template xml>string
diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor
index e3fc9d9bca..2dd2b848be 100644
--- a/basis/xml/tests/test.factor
+++ b/basis/xml/tests/test.factor
@@ -3,7 +3,7 @@
IN: xml.tests
USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
parser strings xml.data io.files xml.writer xml.utilities state-parser
- continuations assocs sequences.deep ;
+ continuations assocs sequences.deep accessors ;
! This is insufficient
\ read-xml must-infer
@@ -11,22 +11,22 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
SYMBOL: xml-file
[ ] [ "resource:basis/xml/tests/test.xml"
[ file>xml ] with-html-entities xml-file set ] unit-test
-[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
-[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test
-[ "a" ] [ xml-file get name-space ] unit-test
-[ "http://www.hello.com" ] [ xml-file get name-url ] unit-test
+[ "1.0" ] [ xml-file get prolog>> version>> ] unit-test
+[ f ] [ xml-file get prolog>> standalone>> ] unit-test
+[ "a" ] [ xml-file get space>> ] unit-test
+[ "http://www.hello.com" ] [ xml-file get url>> ] unit-test
[ "that" ] [
xml-file get T{ name f "" "this" "http://d.de" } swap at
] unit-test
-[ t ] [ xml-file get tag-children second contained-tag? ] unit-test
+[ t ] [ xml-file get children>> second contained-tag? ] unit-test
[ "<a></b>" string>xml ] [ xml-parse-error? ] must-fail-with
[ T{ comment f "This is where the fun begins!" } ] [
xml-file get xml-before [ comment? ] find nip
] unit-test
[ "xsl stylesheet=\"that-one.xsl\"" ] [
- xml-file get xml-after [ instruction? ] find nip instruction-text
+ xml-file get after>> [ instruction? ] find nip text>>
] unit-test
-[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test
+[ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test
[ "that" ] [ xml-file get "this" swap at ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
[ "<a b='c'/>" string>xml xml>string ] unit-test
diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor
index b4ff3a4ce9..284f53023d 100644
--- a/basis/xml/tokenize/tokenize.factor
+++ b/basis/xml/tokenize/tokenize.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: xml.errors xml.data xml.utilities xml.char-classes sets
xml.entities kernel state-parser kernel namespaces strings math
-math.parser sequences assocs arrays splitting combinators unicode.case ;
+math.parser sequences assocs arrays splitting combinators unicode.case
+accessors ;
IN: xml.tokenize
! XML namespace processing: ns = namespace
@@ -14,8 +15,8 @@ SYMBOL: ns-stack
! this should check to make sure URIs are valid
[
[
- swap dup name-space "xmlns" =
- [ name-tag set ]
+ swap dup space>> "xmlns" =
+ [ main>> set ]
[
T{ name f "" "xmlns" f } names-match?
[ "" set ] [ drop ] if
@@ -24,8 +25,8 @@ SYMBOL: ns-stack
] { } make-assoc f like ;
: add-ns ( name -- )
- dup name-space dup ns-stack get assoc-stack
- [ nip ] [ <nonexist-ns> throw ] if* swap set-name-url ;
+ dup space>> dup ns-stack get assoc-stack
+ [ nip ] [ <nonexist-ns> throw ] if* >>url drop ;
: push-ns ( hash -- )
ns-stack get push ;
diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/utilities/utilities.factor
index 209c0b55e9..2acb353bb6 100755
--- a/basis/xml/utilities/utilities.factor
+++ b/basis/xml/utilities/utilities.factor
@@ -10,13 +10,13 @@ IN: xml.utilities
TUPLE: process-missing process tag ;
M: process-missing error.
"Tag <" write
- dup process-missing-tag print-name
+ dup tag>> print-name
"> not implemented on process process " write
- process-missing-process name>> print ;
+ name>> print ;
: run-process ( tag word -- )
2dup "xtable" word-prop
- >r dup name-tag r> at* [ 2nip call ] [
+ >r dup main>> r> at* [ 2nip call ] [
drop \ process-missing boa throw
] if ;
@@ -48,17 +48,18 @@ M: process-missing error.
standard-prolog { } rot { } <xml> ;
: children>string ( tag -- string )
- tag-children {
+ children>> {
{ [ dup empty? ] [ drop "" ] }
- { [ dup [ string? not ] contains? ] [ "XML tag unexpectedly contains non-text children" throw ] }
+ { [ dup [ string? not ] contains? ]
+ [ "XML tag unexpectedly contains non-text children" throw ] }
[ concat ]
} cond ;
: children-tags ( tag -- sequence )
- tag-children [ tag? ] filter ;
+ children>> [ tag? ] filter ;
: first-child-tag ( tag -- tag )
- tag-children [ tag? ] find nip ;
+ children>> [ tag? ] find nip ;
! * Accessing part of an XML document
! for tag- words, a start means that it searches all children
@@ -91,7 +92,7 @@ M: process-missing error.
assure-name [ tag-with-attr? ] 2curry find nip ;
: tags-with-attr ( tag attr-value attr-name -- tags-seq )
- tags@ [ tag-with-attr? ] 2curry filter tag-children ;
+ tags@ [ tag-with-attr? ] 2curry filter children>> ;
: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
assure-name [ tag-with-attr? ] 2curry deep-find ;
@@ -109,8 +110,8 @@ M: process-missing error.
names-match? [ "Unexpected XML tag found" throw ] unless ;
: insert-children ( children tag -- )
- dup tag-children [ push-all ]
- [ >r V{ } like r> set-tag-children ] if ;
+ dup children>> [ push-all ]
+ [ swap V{ } like >>children drop ] if ;
: insert-child ( child tag -- )
>r 1vector r> insert-children ;
diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor
index 41e5422830..13f0be431c 100644
--- a/basis/xml/writer/writer.factor
+++ b/basis/xml/writer/writer.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math namespaces sequences strings
-assocs combinators io io.streams.string
+assocs combinators io io.streams.string accessors
xml.data wrap xml.entities unicode.categories ;
IN: xml.writer
@@ -38,9 +38,9 @@ SYMBOL: indenter
] when ;
: print-name ( name -- )
- dup name-space f like
+ dup space>> f like
[ write CHAR: : write1 ] when*
- name-tag write ;
+ main>> write ;
: print-attrs ( assoc -- )
[
@@ -59,7 +59,7 @@ M: string write-item
: write-tag ( tag -- )
?indent CHAR: < write1
- dup print-name tag-attrs print-attrs ;
+ dup print-name attrs>> print-attrs ;
: write-start-tag ( tag -- )
write-tag ">" write ;
@@ -68,7 +68,7 @@ M: contained-tag write-item
write-tag "/>" write ;
: write-children ( tag -- )
- indent tag-children ?filter-children
+ indent children>> ?filter-children
[ write-item ] each unindent ;
: write-end-tag ( tag -- )
@@ -85,18 +85,18 @@ M: open-tag write-item
r> xml-pprint? set ;
M: comment write-item
- "<!--" write comment-text write "-->" write ;
+ "<!--" write text>> write "-->" write ;
M: directive write-item
- "<!" write directive-text write CHAR: > write1 ;
+ "<!" write text>> write CHAR: > write1 ;
M: instruction write-item
- "<?" write instruction-text write "?>" write ;
+ "<?" write text>> write "?>" write ;
: write-prolog ( xml -- )
- "<?xml version=\"" write dup prolog-version write
- "\" encoding=\"" write dup prolog-encoding write
- prolog-standalone [ "\" standalone=\"yes" write ] when
+ "<?xml version=\"" write dup version>> write
+ "\" encoding=\"" write dup encoding>> write
+ standalone>> [ "\" standalone=\"yes" write ] when
"\"?>" write ;
: write-chunk ( seq -- )
@@ -104,10 +104,10 @@ M: instruction write-item
: write-xml ( xml -- )
{
- [ xml-prolog write-prolog ]
- [ xml-before write-chunk ]
- [ write-item ]
- [ xml-after write-chunk ]
+ [ prolog>> write-prolog ]
+ [ before>> write-chunk ]
+ [ body>> write-item ]
+ [ after>> write-chunk ]
} cleave ;
: print-xml ( xml -- )
diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor
index 4e2ad7a672..67168bfb49 100644
--- a/basis/xml/xml.factor
+++ b/basis/xml/xml.factor
@@ -38,19 +38,19 @@ M: directive process
add-child ;
M: contained process
- [ contained-name ] keep contained-attrs
+ [ name>> ] [ attrs>> ] bi
<contained-tag> add-child ;
M: opener process push-xml ;
: check-closer ( name opener -- name opener )
dup [ <unopened> throw ] unless
- 2dup opener-name =
- [ opener-name swap <mismatched> throw ] unless ;
+ 2dup name>> =
+ [ name>> swap <mismatched> throw ] unless ;
M: closer process
- closer-name pop-xml first2
- >r check-closer opener-attrs r>
+ name>> pop-xml first2
+ >r check-closer attrs>> r>
<tag> add-child ;
: init-xml-stack ( -- )
@@ -102,10 +102,10 @@ TUPLE: pull-xml scope ;
init-parser reset-prolog init-ns-stack
text-now? on
] H{ } make-assoc
- { set-pull-xml-scope } pull-xml construct ;
+ pull-xml boa ;
: pull-event ( pull -- xml-event/f )
- pull-xml-scope [
+ scope>> [
text-now? get [ parse-text f ] [
get-char [ make-tag t ] [ f f ] if
] if text-now? set
@@ -127,17 +127,17 @@ TUPLE: pull-xml scope ;
: call-under ( quot object -- quot )
swap dup slip ; inline
-: sax-loop ( quot -- ) ! quot: xml-elem --
+: sax-loop ( quot: ( xml-elem -- ) -- )
parse-text call-under
get-char [ make-tag call-under sax-loop ]
- [ drop ] if ; inline
+ [ drop ] if ; inline recursive
-: sax ( stream quot -- ) ! quot: xml-elem --
+: sax ( stream quot: ( xml-elem -- ) -- )
swap [
reset-prolog init-ns-stack
prolog-data get call-under
sax-loop
- ] state-parse ; inline
+ ] state-parse ; inline recursive
: (read-xml) ( -- )
[ process ] sax-loop ; inline
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index f1fa13c1d8..6a5dfe30df 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -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 ;
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index d9f1a97299..b43c8f3336 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -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
diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor
index f6ca9184b2..9a372e633e 100644
--- a/core/classes/mixin/mixin-tests.factor
+++ b/core/classes/mixin/mixin-tests.factor
@@ -105,3 +105,7 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
[ ] [ "IN: classes.mixin.tests MIXIN: blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
+
+MIXIN: empty-mixin
+
+[ f ] [ "hi" empty-mixin? ] unit-test
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index a08d4ed20c..56ab6d37f1 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -20,7 +20,9 @@ M: mixin-class rank-class drop 3 ;
dup mixin-class? [
drop
] [
- { } redefine-mixin-class
+ [ { } redefine-mixin-class ]
+ [ update-classes ]
+ bi
] if ;
TUPLE: check-mixin-class mixin ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 4ff9d4c674..4482eb8131 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -270,6 +270,9 @@ M: tuple-class define-tuple-class
tri* define-declared
] 3tri ;
+M: tuple-class update-generic
+ over new-class? [ 2drop ] [ call-next-method ] if ;
+
M: tuple-class reset-class
[
dup "slots" word-prop [
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 70d406a39b..ff81b5ded3 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -62,7 +62,9 @@ TUPLE: check-method class generic ;
[ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
values ;
-: update-generic ( class generic -- )
+GENERIC# update-generic 1 ( class generic -- )
+
+M: class update-generic
affected-methods [ +called+ changed-definition ] each ;
: with-methods ( class generic quot -- )
diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor
index a6fea14fc7..5a496093d5 100755
--- a/core/io/binary/binary-tests.factor
+++ b/core/io/binary/binary-tests.factor
@@ -2,7 +2,9 @@ USING: io.binary tools.test classes math ;
IN: io.binary.tests
[ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test
+[ B{ 0 0 0 0 0 0 4 HEX: d2 } ] [ 1234 8 >be ] unit-test
[ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test
+[ B{ HEX: d2 4 0 0 0 0 0 0 } ] [ 1234 8 >le ] unit-test
[ 1234 ] [ 1234 4 >be be> ] unit-test
[ 1234 ] [ 1234 4 >le le> ] unit-test
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index db0d2da1ef..cf87506bf9 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -324,7 +324,7 @@ TUPLE: pathname string ;
C: <pathname> pathname
-M: pathname <=> [ pathname-string ] compare ;
+M: pathname <=> [ string>> ] compare ;
! Home directory
HOOK: home os ( -- dir )
diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor
index eb6442bbb9..d284be00c9 100644
--- a/core/lexer/lexer.factor
+++ b/core/lexer/lexer.factor
@@ -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 ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 502d4c1eba..487d75cc6c 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -24,7 +24,7 @@ t parser-notes set-global
: note. ( str -- )
parser-notes? [
- file get [ path>> write ] when*
+ file get [ path>> write ":" write ] when*
lexer get line>> number>string write ": " write
"Note: " write dup print
] when drop ;
@@ -216,7 +216,7 @@ SYMBOL: interactive-vocabs
: filter-moved ( assoc1 assoc2 -- seq )
swap assoc-diff [
drop where dup [ first ] when
- file get source-file-path =
+ file get path>> =
] assoc-filter keys ;
: removed-definitions ( -- assoc1 assoc2 )
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 8434a99b30..1bcd01d9b9 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -779,19 +779,19 @@ HELP: collapse-slice
HELP: <flat-slice>
{ $values { "seq" sequence } { "slice" slice } }
-{ $description "Outputs a slice with the same elements as " { $snippet "seq" } ", and " { $link slice-from } " equal to 0 and " { $link slice-to } " equal to the length of " { $snippet "seq" } "." }
+{ $description "Outputs a slice with the same elements as " { $snippet "seq" } ", and " { $snippet "from" } " equal to 0 and " { $snippet "to" } " equal to the length of " { $snippet "seq" } "." }
{ $notes "Some words create slices then proceed to read the " { $snippet "to" } " and " { $snippet "from" } " slots of the slice. To behave predictably when they are themselves given a slice as input, they apply this word first to get a canonical slice." } ;
HELP: <slice>
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "slice" slice } }
{ $description "Outputs a new virtual sequence sharing storage with the subrange of elements in " { $snippet "seq" } " with indices starting from and including " { $snippet "m" } ", and up to but not including " { $snippet "n" } "." }
{ $errors "Throws an error if " { $snippet "m" } " or " { $snippet "n" } " is out of bounds." }
-{ $notes "Taking the slice of a slice outputs a slice of the underlying sequence of the original slice. Keep this in mind when writing code which depends on the values of " { $link slice-from } " and " { $link slice-to } " being equal to the inputs to this word. The " { $link <flat-slice> } " word might be helpful in such situations." } ;
+{ $notes "Taking the slice of a slice outputs a slice of the underlying sequence of the original slice. Keep this in mind when writing code which depends on the values of " { $snippet "from" } " and " { $snippet "to" } " being equal to the inputs to this word. The " { $link <flat-slice> } " word might be helpful in such situations." } ;
{ <slice> subseq } related-words
HELP: repetition
-{ $class-description "A virtual sequence consisting of " { $link repetition-elt } " repeated " { $link repetition-len } " times. Repetitions are created by calling " { $link <repetition> } "." } ;
+{ $class-description "A virtual sequence consisting of " { $snippet "elt" } " repeated " { $snippet "len" } " times. Repetitions are created by calling " { $link <repetition> } "." } ;
HELP: <repetition> ( len elt -- repetition )
{ $values { "len" "a non-negative integer" } { "elt" object } { "repetition" repetition } }
diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor
index fd9796e664..df16f0baa8 100755
--- a/core/slots/deprecated/deprecated.factor
+++ b/core/slots/deprecated/deprecated.factor
@@ -6,15 +6,15 @@ classes slots.private combinators slots ;
IN: slots.deprecated
: reader-effect ( class spec -- effect )
- >r ?word-name 1array r> slot-spec-name 1array <effect> ;
+ >r ?word-name 1array r> name>> 1array <effect> ;
PREDICATE: slot-reader < word "reading" word-prop >boolean ;
: set-reader-props ( class spec -- )
2dup reader-effect
- over slot-spec-reader
+ over reader>>
swap "declared-effect" set-word-prop
- slot-spec-reader swap "reading" set-word-prop ;
+ reader>> swap "reading" set-word-prop ;
: define-slot-word ( class word quot -- )
[
@@ -23,9 +23,9 @@ PREDICATE: slot-reader < word "reading" word-prop >boolean ;
] dip define ;
: define-reader ( class spec -- )
- dup slot-spec-reader [
+ dup reader>> [
[ set-reader-props ] 2keep
- dup slot-spec-reader
+ dup reader>>
swap reader-quot
define-slot-word
] [
@@ -33,20 +33,20 @@ PREDICATE: slot-reader < word "reading" word-prop >boolean ;
] if ;
: writer-effect ( class spec -- effect )
- slot-spec-name swap ?word-name 2array 0 <effect> ;
+ name>> swap ?word-name 2array 0 <effect> ;
PREDICATE: slot-writer < word "writing" word-prop >boolean ;
: set-writer-props ( class spec -- )
2dup writer-effect
- over slot-spec-writer
+ over writer>>
swap "declared-effect" set-word-prop
- slot-spec-writer swap "writing" set-word-prop ;
+ writer>> swap "writing" set-word-prop ;
: define-writer ( class spec -- )
- dup slot-spec-writer [
+ dup writer>> [
[ set-writer-props ] 2keep
- dup slot-spec-writer
+ dup writer>>
swap writer-quot
define-slot-word
] [
diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor
index 2f2f8fd0c0..89ffbfd795 100755
--- a/core/source-files/source-files-docs.factor
+++ b/core/source-files/source-files-docs.factor
@@ -30,10 +30,10 @@ HELP: source-file
{ $description "Outputs the source file associated to a path name, creating the source file first if it doesn't exist. Source files are retained in the " { $link source-files } " variable." }
{ $class-description "Instances retain information about loaded source files, and have the following slots:"
{ $list
- { { $link source-file-path } " - a pathname string." }
- { { $link source-file-checksum } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." }
- { { $link source-file-uses } " - an assoc whose keys are words referenced from this source file's top level form." }
- { { $link source-file-definitions } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" }
+ { { $snippet "path" } " - a pathname string." }
+ { { $snippet "checksum" } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." }
+ { { $snippet "uses" } " - an assoc whose keys are words referenced from this source file's top level form." }
+ { { $snippet "definitions" } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" }
}
} ;
@@ -78,4 +78,4 @@ HELP: rollback-source-file
{ $description "Records information to the source file after an incomplete parse which ended with an error." } ;
HELP: file
-{ $var-description "Stores the " { $link source-file } " being parsed. The " { $link source-file-path } " of this object comes from the input parameter to " { $link with-source-file } "." } ;
+{ $var-description "Stores the " { $link source-file } " being parsed. The " { $snippet "path" } " of this object comes from the input parameter to " { $link with-source-file } "." } ;
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index 50c79fc2c6..aa2cd563a5 100755
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -15,11 +15,11 @@ checksum
uses definitions ;
: record-checksum ( lines source-file -- )
- >r crc32 checksum-lines r> set-source-file-checksum ;
+ [ crc32 checksum-lines ] dip (>>checksum) ;
: (xref-source) ( source-file -- pathname uses )
- dup source-file-path <pathname>
- swap source-file-uses [ crossref? ] filter ;
+ [ path>> <pathname> ]
+ [ uses>> [ crossref? ] filter ] bi ;
: xref-source ( source-file -- )
(xref-source) crossref get add-vertex ;
@@ -31,20 +31,22 @@ uses definitions ;
source-files get [ nip xref-source ] assoc-each ;
: record-form ( quot source-file -- )
- dup unxref-source
- swap quot-uses keys over set-source-file-uses
+ tuck unxref-source
+ quot-uses keys >>uses
xref-source ;
: record-definitions ( file -- )
- new-definitions get swap set-source-file-definitions ;
+ new-definitions get >>definitions drop ;
: <source-file> ( path -- source-file )
\ source-file new
swap >>path
<definitions> >>definitions ;
+ERROR: invalid-source-file-path path ;
+
: source-file ( path -- source-file )
- dup string? [ "Invalid source file path" throw ] unless
+ dup string? [ invalid-source-file-path ] unless
source-files get [ <source-file> ] cache ;
: reset-checksums ( -- )
@@ -70,8 +72,9 @@ M: pathname forget*
pathname-string forget-source ;
: rollback-source-file ( file -- )
- dup source-file-definitions new-definitions get [ assoc-union ] 2map
- swap set-source-file-definitions ;
+ [
+ new-definitions get [ assoc-union ] 2map
+ ] change-definitions drop ;
SYMBOL: file
@@ -87,7 +90,7 @@ TUPLE: source-file-error file error ;
[
swap source-file
dup file set
- source-file-definitions old-definitions set
+ definitions>> old-definitions set
[
file get rollback-source-file
<source-file-error> rethrow
diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor
index 7304df2419..8d95254539 100644
--- a/core/strings/parser/parser.factor
+++ b/core/strings/parser/parser.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs namespaces splitting sequences
-strings math.parser lexer ;
+strings math.parser lexer accessors ;
IN: strings.parser
ERROR: bad-escape ;
@@ -46,7 +46,7 @@ name>char-hook global [
dup [ "\"\\" member? ] find dup [
>r cut-slice >r % r> rest-slice r>
dup CHAR: " = [
- drop slice-from
+ drop from>>
] [
drop next-escape >r , r> (parse-string)
] if
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 3d97dd4cc7..8609cb5b5f 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -3,7 +3,7 @@
USING: namespaces sequences io.files kernel assocs words vocabs
definitions parser continuations io hashtables sorting
source-files arrays combinators strings system math.parser
-compiler.errors splitting init ;
+compiler.errors splitting init accessors ;
IN: vocabs.loader
SYMBOL: vocab-roots
@@ -51,32 +51,23 @@ H{ } clone root-cache set-global
SYMBOL: load-help?
-: source-was-loaded ( vocab -- ) t swap set-vocab-source-loaded? ;
+: load-source ( vocab -- vocab )
+ f >>source-loaded?
+ [ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep
+ t >>source-loaded?
+ [ [ % ] [ call ] if-bootstrapping ] dip ;
-: source-wasn't-loaded ( vocab -- ) f swap set-vocab-source-loaded? ;
-: load-source ( vocab -- )
- [ source-wasn't-loaded ]
- [ vocab-source-path [ parse-file ] [ [ ] ] if* ]
- [ source-was-loaded ]
- tri
- [ % ] [ call ] if-bootstrapping ;
-
-: docs-were-loaded ( vocab -- ) t swap set-vocab-docs-loaded? ;
-
-: docs-weren't-loaded ( vocab -- ) f swap set-vocab-docs-loaded? ;
-
-: load-docs ( vocab -- )
+: load-docs ( vocab -- vocab )
load-help? get [
- [ docs-weren't-loaded ]
- [ vocab-docs-path [ ?run-file ] when* ]
- [ docs-were-loaded ]
- tri
- ] [ drop ] if ;
+ f >>docs-loaded?
+ [ vocab-docs-path [ ?run-file ] when* ] keep
+ t >>docs-loaded?
+ ] when ;
: reload ( name -- )
[
- dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if
+ dup vocab [ load-source load-docs drop ] [ no-vocab ] ?if
] with-compiler-errors ;
: require ( vocab -- )
@@ -100,8 +91,8 @@ GENERIC: (load-vocab) ( name -- )
M: vocab (load-vocab)
[
- dup vocab-source-loaded? [ dup load-source ] unless
- dup vocab-docs-loaded? [ dup load-docs ] unless
+ dup vocab-source-loaded? [ load-source ] unless
+ dup vocab-docs-loaded? [ load-docs ] unless
drop
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor
index 99daee06f3..324f8e755f 100755
--- a/core/words/words-docs.factor
+++ b/core/words/words-docs.factor
@@ -124,13 +124,11 @@ $nl
{ { { $snippet "\"inferred-effect\"" } } { $link "inference" } }
- { { $snippet "\"specializer\"" } { $link "specializers" } }
+ { { $snippet "\"specializer\"" } { $link "hints" } }
{ { { $snippet "\"intrinsics\"" } ", " { $snippet "\"if-intrinsics\"" } } { $link "generator" } }
{ { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" }
-
- { { { $snippet "\"constructing\"" } ", " { $snippet "\"constructor-quot\"" } } { $link "tuple-constructors" } }
}
"Properties which are defined for classes only:"
{ $table
@@ -163,12 +161,12 @@ ARTICLE: "words" "Words"
$nl
"Word introspection facilities and implementation details are found in the " { $vocab-link "words" } " vocabulary."
$nl
-"A word consists of several parts:"
-{ $list
- "a word name,"
- "a vocabulary name,"
- "a definition quotation, called when the word when executed,"
- "a set of word properties, including documentation and other meta-data."
+"Word objects contain several slots:"
+{ $table
+ { { $snippet "name" } "a word name" }
+ { { $snippet "vocabulary" } "a word vocabulary name" }
+ { { $snippet "def" } "a definition quotation" }
+ { { $snippet "props" } "an assoc of word properties, including documentation and other meta-data" }
}
"Words are instances of a class."
{ $subsection word }
diff --git a/extra/24-game/24-game-docs.factor b/extra/24-game/24-game-docs.factor
index cd82f335d8..996d0a1240 100644
--- a/extra/24-game/24-game-docs.factor
+++ b/extra/24-game/24-game-docs.factor
@@ -35,8 +35,8 @@ HELP: 24-able ( -- vector )
}
{ $examples
{ $example
- "USE: 24-game"
- "24-able vector-24-able? ."
+ "USING: 24-game prettyprint ;"
+ "24-able 24-able? ."
"t"
}
{ $notes { $link 24-able? } " is used in " { $link 24-able } "." }
@@ -54,7 +54,7 @@ HELP: 24-able? ( quad -- t/f )
HELP: build-quad ( -- array )
{ $values
- { "vector" "an array of 4 numbers" }
+ { "array" "an array of 4 numbers" }
}
{ $description "Builds an array of 4 random numbers." } ;
ARTICLE: "24-game" "The Game of 24"
@@ -64,4 +64,4 @@ ARTICLE: "24-game" "The Game of 24"
{ $subsection 24-able }
{ $subsection 24-able? }
{ $subsection build-quad } ;
-ABOUT: "24-game"
\ No newline at end of file
+ABOUT: "24-game"
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 410a97d90f..b2577e6636 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -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 ] ;
@@ -150,4 +150,4 @@ MACRO: predicates ( seq -- quot/f )
>r [ [ dup ] prepend ] map r> zip [ drop f ] suffix
[ cond ] curry ;
-: %chance ( quot integer -- ) 100 random > swap when ; inline
+: %chance ( quot n -- ) 100 random > swap when ; inline
diff --git a/extra/csv/csv.factor b/extra/csv/csv.factor
index 9779c37ed4..59a3f21863 100644
--- a/extra/csv/csv.factor
+++ b/extra/csv/csv.factor
@@ -84,5 +84,5 @@ DEFER: quoted-field ( -- endchar )
: write-row ( row -- )
[ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline
-: write-csv ( rows outstream -- )
+: write-csv ( rows stream -- )
[ [ write-row ] each ] with-output-stream ;
diff --git a/extra/ctags/ctags-docs.factor b/extra/ctags/ctags-docs.factor
index 32f3e05c6e..b984cdce54 100644
--- a/extra/ctags/ctags-docs.factor
+++ b/extra/ctags/ctags-docs.factor
@@ -23,7 +23,7 @@ HELP: ctags ( path -- )
} ;
HELP: ctags-write ( seq path -- )
-{ $values { "alist" "an association list" }
+{ $values { "seq" sequence }
{ "path" "a pathname string" } }
{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" }
{ $examples
@@ -97,4 +97,4 @@ HELP: ctag-word ( ctag -- word )
} ;
-ABOUT: "ctags"
\ No newline at end of file
+ABOUT: "ctags"
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 889eff196c..c52d1db148 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -96,12 +96,12 @@ M: object execute-statement* ( statement type -- )
: sql-row-typed ( result-set -- seq )
dup #columns [ row-column-typed ] with map ;
-: query-each ( statement quot -- )
+: query-each ( statement quot: ( statement -- ) -- )
over more-rows? [
[ call ] 2keep over advance-row query-each
] [
2drop
- ] if ; inline
+ ] if ; inline recursive
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline
diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor
index 7960eecee5..3a751a9736 100644
--- a/extra/db/queries/queries.factor
+++ b/extra/db/queries/queries.factor
@@ -14,7 +14,7 @@ GENERIC: where ( specs obj -- )
: query-make ( class quot -- )
>r sql-props r>
- [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
+ [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
<simple-statement> maybe-make-retryable ; inline
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 2edf7552cb..f5b74b51c8 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -84,8 +84,8 @@ SYMBOL: person4
10
3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
}
] [ T{ person f 3 } select-tuple ] unit-test
@@ -100,8 +100,8 @@ SYMBOL: person4
10
3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f
H{ { 1 2 } { 3 4 } { 5 "lol" } }
URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
@@ -129,12 +129,12 @@ SYMBOL: person4
"teddy" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
"eddie" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <person> person4 set ;
: user-assigned-person-schema ( -- )
@@ -156,13 +156,13 @@ SYMBOL: person4
3 "teddy" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
f f <user-assigned-person> person3 set
4 "eddie" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
- T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
TUPLE: paste n summary author channel mode contents timestamp annotations ;
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index e02e21cbe6..71cf878d2f 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -127,12 +127,12 @@ M: retryable execute-statement* ( statement type -- )
: insert-db-assigned-statement ( tuple -- )
dup class
- db get db-insert-statements [ <insert-db-assigned-statement> ] cache
+ db get insert-statements>> [ <insert-db-assigned-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ;
: insert-user-assigned-statement ( tuple -- )
dup class
- db get db-insert-statements [ <insert-user-assigned-statement> ] cache
+ db get insert-statements>> [ <insert-user-assigned-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index f6d54404de..c3480093c5 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -143,7 +143,7 @@ HOOK: bind# db ( spec obj -- )
: offset-of-slot ( str obj -- n )
class superclasses [ "slots" word-prop ] map concat
- slot-named slot-spec-offset ;
+ slot-named offset>> ;
: get-slot-named ( name obj -- value )
tuck offset-of-slot slot ;
diff --git a/extra/graph-theory/graph-theory-docs.factor b/extra/graph-theory/graph-theory-docs.factor
index 82d8b9adf6..39c116372d 100644
--- a/extra/graph-theory/graph-theory-docs.factor
+++ b/extra/graph-theory/graph-theory-docs.factor
@@ -76,16 +76,16 @@ HELP: add-edge*
{ "from" "The index of a vertex" }
{ "to" "The index of another vertex" }
{ "graph" "A graph" } }
-{ $description "Adds a one-way edge to the graph, between from and to."
+{ $description "Adds a one-way edge to the graph, between " { $snippet "from" } " and " { $snippet "to" } "."
$nl
"If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
HELP: add-edge
{ $values
- { "m" "The index of a vertex" }
- { "n" "The index of another vertex" }
+ { "u" "The index of a vertex" }
+ { "v" "The index of another vertex" }
{ "graph" "A graph" } }
-{ $description "Adds a two-way edge to the graph, between m and n."
+{ $description "Adds a two-way edge to the graph, between " { $snippet "u" } " and " { $snippet "v" } "."
$nl
"If you want to add a one-way edge, use " { $link add-edge* } " instead." } ;
diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor
index 103020ee0f..67a7dc2045 100644
--- a/extra/html/templates/chloe/chloe.factor
+++ b/extra/html/templates/chloe/chloe.factor
@@ -28,6 +28,7 @@ DEFER: process-template
[ drop name-url chloe-ns = not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
+ dup xml? [ body>> ] when
{
{ [ dup tag? not ] [ f ] }
{ [ dup url>> chloe-ns = not ] [ f ] }
@@ -112,12 +113,12 @@ CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code
: process-chloe-tag ( tag -- )
- dup name-tag dup tags get at
+ dup main>> dup tags get at
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
: process-tag ( tag -- )
{
- [ name-tag >lower tag-stack get push ]
+ [ main>> >lower tag-stack get push ]
[ write-start-tag ]
[ process-tag-children ]
[ write-end-tag ]
@@ -125,7 +126,7 @@ CHLOE-TUPLE: code
} cleave ;
: expand-attrs ( tag -- tag )
- dup [ tag? ] is? [
+ dup [ tag? ] [ xml? ] bi or [
clone [
[ "@" ?head [ value present ] when ] assoc-map
] change-attrs
@@ -134,8 +135,8 @@ CHLOE-TUPLE: code
: process-template ( xml -- )
expand-attrs
{
- { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
- { [ dup [ tag? ] is? ] [ process-tag ] }
+ { [ dup chloe-tag? ] [ process-chloe-tag ] }
+ { [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] }
{ [ t ] [ write-item ] }
} cond ;
diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/extra/html/templates/chloe/syntax/syntax.factor
index 9412fde423..82309a49b2 100644
--- a/extra/html/templates/chloe/syntax/syntax.factor
+++ b/extra/html/templates/chloe/syntax/syntax.factor
@@ -23,7 +23,7 @@ tags global [ H{ } clone or ] change-at
MEMO: chloe-name ( string -- name )
name new
- swap >>tag
+ swap >>main
chloe-ns >>url ;
: required-attr ( tag name -- value )
@@ -45,7 +45,7 @@ MEMO: chloe-name ( string -- name )
: attrs>slots ( tag tuple -- )
[ attrs>> ] [ <mirror> ] bi*
'[
- swap tag>> dup "name" =
+ swap main>> dup "name" =
[ 2drop ] [ , set-at ] if
] assoc-each ;
diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor
index 0df41cf53f..3206636ea9 100644
--- a/extra/inverse/inverse-tests.factor
+++ b/extra/inverse/inverse-tests.factor
@@ -62,10 +62,10 @@ C: <nil> nil
[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
: empty-cons ( -- cons ) cons new ;
-: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
+: cons* ( cdr car -- cons ) cons boa ;
[ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
-[ 1 2 ] [ 2 1 <cons> [ cons* ] undo ] unit-test
+[ 1 2 ] [ 1 2 <cons> [ cons* ] undo ] unit-test
[ t ] [ pi [ pi ] matches? ] unit-test
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index edcf0c7d26..72a74baf68 100755
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -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 ;
diff --git a/extra/io/files/unique/unique-tests.factor b/extra/io/files/unique/unique-tests.factor
index 7007f593b6..c29a94f395 100644
--- a/extra/io/files/unique/unique-tests.factor
+++ b/extra/io/files/unique/unique-tests.factor
@@ -1,3 +1,5 @@
+USING: io.encodings.ascii sequences strings io io.files accessors
+tools.test kernel io.files.unique ;
IN: io.files.unique.tests
[ 123 ] [
diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor
index 15faf8d002..cd2e6f7081 100644
--- a/extra/lists/lists-docs.factor
+++ b/extra/lists/lists-docs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
+USING: kernel help.markup help.syntax ;
IN: lists
@@ -23,7 +23,7 @@ HELP: nil
{ $description "Returns a symbol representing the empty list" } ;
HELP: nil?
-{ $values { "cons" "a cons object" } { "?" "a boolean" } }
+{ $values { "object" object } { "?" "a boolean" } }
{ $description "Return true if the cons object is the nil cons." } ;
HELP: list? ( object -- ? )
diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor
index 72b33b9ae7..1e755d71d9 100644
--- a/extra/math/bitfields/lib/lib.factor
+++ b/extra/math/bitfields/lib/lib.factor
@@ -1,14 +1,14 @@
USING: hints kernel math ;
IN: math.bitfields.lib
-: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
-: set-bit ( x n -- y ) 2^ bitor ; foldable
-: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
-: unmask ( x n -- ? ) bitnot bitand ; foldable
-: unmask? ( x n -- ? ) unmask 0 > ; foldable
-: mask ( x n -- ? ) bitand ; foldable
-: mask? ( x n -- ? ) mask 0 > ; foldable
-: wrap ( m n -- m' ) 1- bitand ; foldable
+: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
+: set-bit ( x n -- y ) 2^ bitor ; inline
+: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
+: unmask ( x n -- ? ) bitnot bitand ; inline
+: unmask? ( x n -- ? ) unmask 0 > ; inline
+: mask ( x n -- ? ) bitand ; inline
+: mask? ( x n -- ? ) mask 0 > ; inline
+: wrap ( m n -- m' ) 1- bitand ; inline
: bits ( m n -- m' ) 2^ wrap ; inline
: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
diff --git a/extra/math/blas/syntax/syntax.factor b/extra/math/blas/syntax/syntax.factor
index d6e76ecd85..1072c64b32 100644
--- a/extra/math/blas/syntax/syntax.factor
+++ b/extra/math/blas/syntax/syntax.factor
@@ -2,22 +2,22 @@ USING: kernel math.blas.matrices math.blas.vectors parser
arrays prettyprint.backend sequences ;
IN: math.blas.syntax
-: svector{ ( accum -- accum )
+: svector{
\ } [ >float-blas-vector ] parse-literal ; parsing
-: dvector{ ( accum -- accum )
+: dvector{
\ } [ >double-blas-vector ] parse-literal ; parsing
-: cvector{ ( accum -- accum )
+: cvector{
\ } [ >float-complex-blas-vector ] parse-literal ; parsing
-: zvector{ ( accum -- accum )
+: zvector{
\ } [ >double-complex-blas-vector ] parse-literal ; parsing
-: smatrix{ ( accum -- accum )
+: smatrix{
\ } [ >float-blas-matrix ] parse-literal ; parsing
-: dmatrix{ ( accum -- accum )
+: dmatrix{
\ } [ >double-blas-matrix ] parse-literal ; parsing
-: cmatrix{ ( accum -- accum )
+: cmatrix{
\ } [ >float-complex-blas-matrix ] parse-literal ; parsing
-: zmatrix{ ( accum -- accum )
+: zmatrix{
\ } [ >double-complex-blas-matrix ] parse-literal ; parsing
M: float-blas-vector pprint-delims drop \ svector{ \ } ;
diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor
index 15dd954b1c..8e561f38ae 100644
--- a/extra/math/derivatives/derivatives-docs.factor
+++ b/extra/math/derivatives/derivatives-docs.factor
@@ -1,8 +1,8 @@
-USING: help.markup help.syntax math.functions ;
+USING: help.markup help.syntax math math.functions ;
IN: math.derivatives
HELP: derivative ( x function -- m )
-{ $values { "x" "a position on the function" } { "function" "a differentiable function" } }
+{ $values { "x" "a position on the function" } { "function" "a differentiable function" } { "m" number } }
{ $description
"Approximates the slope of the tangent line by using Ridders' "
"method of computing derivatives, from the chapter \"Accurate computation "
@@ -10,8 +10,8 @@ HELP: derivative ( x function -- m )
}
{ $examples
{ $example
- "USING: math.derivatives prettyprint ;"
- "[ sq ] 4 derivative ."
+ "USING: math math.derivatives prettyprint ;"
+ "4 [ sq ] derivative >integer ."
"8"
}
{ $notes
@@ -20,10 +20,10 @@ HELP: derivative ( x function -- m )
}
} ;
-HELP: (derivative) ( x function h err -- m )
+HELP: (derivative)
{ $values
{ "x" "a position on the function" }
- { "function" "a differentiable function" }
+ { "func" "a differentiable function" }
{
"h" "distance between the points of the first secant line used for "
"approximation of the tangent. This distance will be divided "
@@ -41,6 +41,8 @@ HELP: (derivative) ( x function h err -- m )
"when the error multiplies by 2. See " { $link check-safe } " for "
"the enforcing code."
}
+ { "ans" number }
+ { "error" number }
}
{ $description
"Approximates the slope of the tangent line by using Ridders' "
@@ -50,8 +52,8 @@ HELP: (derivative) ( x function h err -- m )
}
{ $examples
{ $example
- "USING: math.derivatives prettyprint ;"
- "[ sq ] 4 derivative ."
+ "USING: math math.derivatives prettyprint ;"
+ "4 [ sq ] derivative >integer ."
"8"
}
{ $notes
@@ -60,7 +62,7 @@ HELP: (derivative) ( x function h err -- m )
}
} ;
-HELP: derivative-func ( function -- der )
+HELP: derivative-func
{ $values { "func" "a differentiable function" } { "der" "the derivative" } }
{ $description
"Provides the derivative of the function. The implementation simply "
@@ -68,7 +70,7 @@ HELP: derivative-func ( function -- der )
}
{ $examples
{ $example
- "USING: math.derivatives prettyprint ;"
+ "USING: kernel math.derivatives math.functions math.trig prettyprint ;"
"60 deg>rad [ sin ] derivative-func call ."
"0.5000000000000173"
}
diff --git a/extra/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor
index d4cab29f6a..6e83a61eb3 100755
--- a/extra/math/matrices/elimination/elimination.factor
+++ b/extra/math/matrices/elimination/elimination.factor
@@ -31,10 +31,10 @@ SYMBOL: matrix
>r over r> nth dup zero? [
3drop 0
] [
- >r nth dup zero? [
- r> 2drop 0
+ >r nth dup zero? r> swap [
+ 2drop 0
] [
- r> swap / neg
+ swap / neg
] if
] if ;
diff --git a/extra/namespaces/lib/lib-tests.factor b/extra/namespaces/lib/lib-tests.factor
index 20769e161c..0bc2e6311a 100755
--- a/extra/namespaces/lib/lib-tests.factor
+++ b/extra/namespaces/lib/lib-tests.factor
@@ -1,6 +1,8 @@
IN: namespaces.lib.tests
-USING: namespaces.lib tools.test ;
+USING: namespaces.lib kernel tools.test ;
[ ] [ [ ] { } nmake ] unit-test
[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test
+
+[ [ ] [ call ] curry { { } } nmake ] must-infer
diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor
index 4da3935727..da9fde9d79 100755
--- a/extra/namespaces/lib/lib.factor
+++ b/extra/namespaces/lib/lib.factor
@@ -1,8 +1,6 @@
-
-! USING: kernel quotations namespaces sequences assocs.lib ;
-
USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib math.parser math generalizations locals mirrors ;
+ assocs.lib math.parser math generalizations locals mirrors
+ macros ;
IN: namespaces.lib
@@ -42,22 +40,20 @@ SYMBOL: building-seq
: 4% ( seq -- ) 4 n% ;
: 4# ( num -- ) 4 n# ;
-MACRO:: nmake ( quot exemplars -- )
- [let | n [ exemplars length ] |
- [
- [
- exemplars
- [ 0 swap new-resizable ] map
- building-seq set
+MACRO: finish-nmake ( exemplars -- )
+ length [ firstn ] curry ;
- quot call
+:: nmake ( quot exemplars -- )
+ [
+ exemplars
+ [ 0 swap new-resizable ] map
+ building-seq set
- building-seq get
- exemplars [ like ] 2map
- n firstn
- ] with-scope
- ]
- ] ;
+ quot call
+
+ building-seq get
+ exemplars [ [ like ] 2map ] [ finish-nmake ] bi
+ ] with-scope ; inline
: make-object ( quot class -- object )
new [ <mirror> swap bind ] keep ; inline
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 3d93b0ad06..0cf0382ee2 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -110,7 +110,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
: input-from ( input -- n )
#! Return the index from the original string that the
#! input slice is based on.
- dup slice? [ slice-from ] [ drop 0 ] if ;
+ dup slice? [ from>> ] [ drop 0 ] if ;
: process-rule-result ( p result -- result )
[
diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor
index b9ce6a8557..5d63406e78 100755
--- a/extra/promises/promises.factor
+++ b/extra/promises/promises.factor
@@ -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 )
[
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 9a0b86dbe3..9e984857f6 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -193,7 +193,7 @@ USE: continuations
[
iterate-step roll
[ 3nip ] [ iterate-next (attempt-each-integer) ] if*
- ] [ 3drop f ] if-iterate? ; inline
+ ] [ 3drop f ] if-iterate? ; inline recursive
PRIVATE>
: attempt-each ( seq quot -- result )
diff --git a/extra/syndication/syndication.factor b/extra/syndication/syndication.factor
index 8d4c91177a..2fa8abcd59 100644
--- a/extra/syndication/syndication.factor
+++ b/extra/syndication/syndication.factor
@@ -76,8 +76,8 @@ TUPLE: entry title url description date ;
[ "link" tag-named "href" swap at >url >>url ]
[
{ "content" "summary" } any-tag-named
- dup tag-children [ string? not ] contains?
- [ tag-children [ write-chunk ] with-string-writer ]
+ dup children>> [ string? not ] contains?
+ [ children>> [ write-chunk ] with-string-writer ]
[ children>string ] if >>description
]
[
@@ -96,7 +96,7 @@ TUPLE: entry title url description date ;
tri ;
: xml>feed ( xml -- feed )
- dup name-tag {
+ dup main>> {
{ "RDF" [ rss1.0 ] }
{ "rss" [ rss2.0 ] }
{ "feed" [ atom1.0 ] }
diff --git a/extra/wordtimer/wordtimer-docs.factor b/extra/wordtimer/wordtimer-docs.factor
index c13399e0f8..cfe6cfea49 100644
--- a/extra/wordtimer/wordtimer-docs.factor
+++ b/extra/wordtimer/wordtimer-docs.factor
@@ -1,4 +1,5 @@
-USING: help.syntax help.markup kernel prettyprint sequences ;
+USING: help.syntax help.markup kernel prettyprint sequences
+quotations words strings ;
IN: wordtimer
HELP: reset-word-timer
@@ -6,18 +7,18 @@ HELP: reset-word-timer
} ;
HELP: add-timer
-{ $values { "word" "a word" } }
+{ $values { "word" word } }
{ $description "annotates the word with timing code which stores timing information globally. You can then view the info with print-word-timings"
} ;
HELP: add-timers
-{ $values { "vocab" "a string" } }
+{ $values { "vocab" string } }
{ $description "annotates all the words in the vocab with timer code. After profiling you can remove the annotations with reset-vocab"
} ;
HELP: reset-vocab
-{ $values { "vocab" "a string" } }
+{ $values { "vocab" string } }
{ $description "removes the annotations from all the words in the vocab"
} ;
@@ -29,13 +30,13 @@ HELP: correct-for-timing-overhead
{ $description "attempts to correct the timings to take into account the overhead of the timing function. This is pretty error-prone but can be handy when you're timing words that only take a handful of milliseconds but are called a lot" } ;
HELP: profile-vocab
-{ $values { "vocabspec" "string name of a vocab" }
+{ $values { "vocab" string }
{ "quot" "a quotation to run" } }
{ $description "Annotates the words in the vocab with timing code then runs the quotation. Finally resets the words and prints the timings information."
} ;
HELP: wordtimer-call
-{ $values { "quot" "a quotation to run" } }
+{ $values { "quot" quotation } }
{ $description "Resets the wordtimer hash and runs the quotation. After the quotation has run it prints out the timed words"
} ;
diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor
index 15f50faa15..5dc65c661b 100644
--- a/extra/wordtimer/wordtimer.factor
+++ b/extra/wordtimer/wordtimer.factor
@@ -40,10 +40,10 @@ SYMBOL: *calling*
: add-timer ( word -- )
dup [ (add-timer) ] annotate ;
-: add-timers ( vocabspec -- )
+: add-timers ( vocab -- )
words [ add-timer ] each ;
-: reset-vocab ( vocabspec -- )
+: reset-vocab ( vocab -- )
words [ reset ] each ;
: dummy-word ( -- ) ;
@@ -74,7 +74,7 @@ SYMBOL: *calling*
"total time:" write r> pprint nl
print-word-timings nl ;
-: profile-vocab ( vocabspec quot -- )
+: profile-vocab ( vocab quot -- )
"annotating vocab..." print flush
over [ reset-vocab ] [ add-timers ] bi
reset-word-timer
@@ -84,4 +84,4 @@ SYMBOL: *calling*
reset-vocab
correct-for-timing-overhead
"total time:" write r> pprint
- print-word-timings ;
\ No newline at end of file
+ print-word-timings ;
diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor
index 4c95a45832..8b66774d7f 100644
--- a/extra/xmode/loader/syntax/syntax.factor
+++ b/extra/xmode/loader/syntax/syntax.factor
@@ -1,4 +1,4 @@
-USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
+USING: accessors xmode.tokens xmode.rules xmode.keyword-map xml.data
xml.utilities xml assocs kernel combinators sequences
math.parser namespaces parser lexer xmode.utilities regexp io.files ;
IN: xmode.loader.syntax
@@ -7,7 +7,7 @@ SYMBOL: ignore-case?
! Rule tag parsing utilities
: (parse-rule-tag) ( rule-set tag specs class -- )
- construct-rule swap init-from-tag swap add-rule ; inline
+ new swap init-from-tag swap add-rule ; inline
: RULE:
scan scan-word
@@ -98,4 +98,4 @@ TAGS>
: init-eol-span-tag ( -- ) [ drop init-eol-span ] , ;
: parse-keyword-tag ( tag keyword-map -- )
- >r dup name-tag string>token swap children>string r> set-at ;
+ >r dup main>> string>token swap children>string r> set-at ;
diff --git a/extra/xmode/marker/context/context.factor b/extra/xmode/marker/context/context.factor
index 72ac3f2a3f..da20503fcb 100644
--- a/extra/xmode/marker/context/context.factor
+++ b/extra/xmode/marker/context/context.factor
@@ -1,4 +1,4 @@
-USING: kernel ;
+USING: accessors kernel ;
IN: xmode.marker.context
! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
@@ -11,10 +11,9 @@ end
: <line-context> ( ruleset parent -- line-context )
over [ "no context" throw ] unless
- { set-line-context-in-rule-set set-line-context-parent }
- line-context construct ;
+ line-context new
+ swap >>parent
+ swap >>in-rule-set ;
M: line-context clone
- (clone)
- dup line-context-parent clone
- over set-line-context-parent ;
+ call-next-method [ clone ] change-parent ;
diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor
index 3fcae02a54..50d2924b61 100755
--- a/extra/xmode/rules/rules.factor
+++ b/extra/xmode/rules/rules.factor
@@ -66,14 +66,11 @@ delegate
chars
;
-: construct-rule ( class -- rule )
- >r rule new r> construct-delegate ; inline
+TUPLE: seq-rule < rule ;
-TUPLE: seq-rule ;
+TUPLE: span-rule < rule ;
-TUPLE: span-rule ;
-
-TUPLE: eol-span-rule ;
+TUPLE: eol-span-rule < rule ;
: init-span ( rule -- )
dup rule-delegate [ drop ] [
@@ -85,16 +82,15 @@ TUPLE: eol-span-rule ;
dup init-span
t swap set-rule-no-line-break? ;
-TUPLE: mark-following-rule ;
+TUPLE: mark-following-rule < rule ;
-TUPLE: mark-previous-rule ;
+TUPLE: mark-previous-rule < rule ;
-TUPLE: escape-rule ;
+TUPLE: escape-rule < rule ;
: <escape-rule> ( string -- rule )
f <string-matcher> f f f <matcher>
- escape-rule construct-rule
- [ set-rule-start ] keep ;
+ escape-rule new swap >>start ;
GENERIC: text-hash-char ( text -- ch )
diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor
index 55b6bbe26a..49a1265b09 100755
--- a/extra/xmode/utilities/utilities-tests.factor
+++ b/extra/xmode/utilities/utilities-tests.factor
@@ -1,7 +1,7 @@
IN: xmode.utilities.tests
-USING: xmode.utilities tools.test xml xml.data kernel strings
-vectors sequences io.files prettyprint assocs unicode.case ;
-
+USING: accessors xmode.utilities tools.test xml xml.data kernel
+strings vectors sequences io.files prettyprint assocs
+unicode.case ;
[ "hi" 3 ] [
{ 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find
] unit-test
@@ -35,7 +35,7 @@ TAGS>
{ { "type" >upper set-company-type } }
init-from-tag dup
] keep
- tag-children [ tag? ] filter
+ children>> [ tag? ] filter
[ parse-employee-tag ] with each ;
[
diff --git a/extra/xmode/utilities/utilities.factor b/extra/xmode/utilities/utilities.factor
index d6f9c42799..8f1a6184e8 100644
--- a/extra/xmode/utilities/utilities.factor
+++ b/extra/xmode/utilities/utilities.factor
@@ -1,10 +1,10 @@
-USING: sequences assocs kernel quotations namespaces xml.data
-xml.utilities combinators macros parser lexer words ;
+USING: accessors sequences assocs kernel quotations namespaces
+xml.data xml.utilities combinators macros parser lexer words ;
IN: xmode.utilities
: implies >r not r> or ; inline
-: child-tags ( tag -- seq ) tag-children [ tag? ] filter ;
+: child-tags ( tag -- seq ) children>> [ tag? ] filter ;
: map-find ( seq quot -- result elt )
f -rot
@@ -53,5 +53,5 @@ SYMBOL: tag-handler-word
: TAGS>
tag-handler-word get
- tag-handlers get >alist [ >r dup name-tag r> case ] curry
+ tag-handlers get >alist [ >r dup main>> r> case ] curry
define ; parsing
diff --git a/unfinished/regexp2/backend/backend.factor b/unfinished/regexp2/backend/backend.factor
index c39d67e7b8..81ffb334bd 100644
--- a/unfinished/regexp2/backend/backend.factor
+++ b/unfinished/regexp2/backend/backend.factor
@@ -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 } ;
diff --git a/unfinished/regexp2/dfa/dfa.factor b/unfinished/regexp2/dfa/dfa.factor
index 0dcf6c4ab5..468ffa73e5 100644
--- a/unfinished/regexp2/dfa/dfa.factor
+++ b/unfinished/regexp2/dfa/dfa.factor
@@ -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 ;
diff --git a/unfinished/regexp2/nfa/nfa.factor b/unfinished/regexp2/nfa/nfa.factor
index f87a2a7b52..792d9fe30f 100644
--- a/unfinished/regexp2/nfa/nfa.factor
+++ b/unfinished/regexp2/nfa/nfa.factor
@@ -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
diff --git a/unfinished/regexp2/parser/parser.factor b/unfinished/regexp2/parser/parser.factor
index 39ca01e319..206db3883d 100644
--- a/unfinished/regexp2/parser/parser.factor
+++ b/unfinished/regexp2/parser/parser.factor
@@ -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 [
diff --git a/unfinished/regexp2/regexp2-tests.factor b/unfinished/regexp2/regexp2-tests.factor
index 2bb194f012..88bbc5f56c 100644
--- a/unfinished/regexp2/regexp2-tests.factor
+++ b/unfinished/regexp2/regexp2-tests.factor
@@ -222,6 +222,8 @@ IN: regexp2-tests
<regexp> drop
] unit-test
+! Comment
+[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
diff --git a/unfinished/regexp2/regexp2.factor b/unfinished/regexp2/regexp2.factor
index 0b8994ca2b..efc5c660de 100644
--- a/unfinished/regexp2/regexp2.factor
+++ b/unfinished/regexp2/regexp2.factor
@@ -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- ;
diff --git a/unfinished/regexp2/transition-tables/transition-tables.factor b/unfinished/regexp2/transition-tables/transition-tables.factor
index 0547846655..c67985af4a 100644
--- a/unfinished/regexp2/transition-tables/transition-tables.factor
+++ b/unfinished/regexp2/transition-tables/transition-tables.factor
@@ -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 ;
diff --git a/unfinished/regexp2/traversal/traversal.factor b/unfinished/regexp2/traversal/traversal.factor
index 94e96bb935..a5db2cdaa8 100644
--- a/unfinished/regexp2/traversal/traversal.factor
+++ b/unfinished/regexp2/traversal/traversal.factor
@@ -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 )
diff --git a/unfinished/regexp2/utils/utils.factor b/unfinished/regexp2/utils/utils.factor
index a7606e0af3..48c68d883f 100644
--- a/unfinished/regexp2/utils/utils.factor
+++ b/unfinished/regexp2/utils/utils.factor
@@ -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 ;