From abe2eb462fea3431ff6cb20531fb944f81c10673 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 27 Aug 2008 15:09:49 -0500 Subject: [PATCH 01/55] updated regexp2 for new compiler, add a slot for lookahead --- unfinished/regexp2/dfa/dfa.factor | 2 +- unfinished/regexp2/nfa/nfa.factor | 4 ++-- .../transition-tables/transition-tables.factor | 11 +++++++---- unfinished/regexp2/traversal/traversal.factor | 5 ++++- unfinished/regexp2/utils/utils.factor | 2 +- 5 files changed, 15 insertions(+), 9 deletions(-) diff --git a/unfinished/regexp2/dfa/dfa.factor b/unfinished/regexp2/dfa/dfa.factor index 0dcf6c4ab5..532ee130bc 100644 --- a/unfinished/regexp2/dfa/dfa.factor +++ b/unfinished/regexp2/dfa/dfa.factor @@ -42,7 +42,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 f transition boa r> dfa-table>> add-transition ] curry with each new-transitions ] if-empty ; diff --git a/unfinished/regexp2/nfa/nfa.factor b/unfinished/regexp2/nfa/nfa.factor index f87a2a7b52..1dada10d52 100644 --- a/unfinished/regexp2/nfa/nfa.factor +++ b/unfinished/regexp2/nfa/nfa.factor @@ -30,10 +30,10 @@ GENERIC: nfa-node ( node -- ) stack [ regexp stack>> ] table [ regexp nfa-table>> ] | negated? [ - s0 f obj class boa table add-transition + s0 f obj f class boa table add-transition s0 s1 table add-transition ] [ - s0 s1 obj class boa table add-transition + s0 s1 obj f class boa table add-transition ] if s0 s1 2array stack push t s1 table final-states>> set-at ] ; diff --git a/unfinished/regexp2/transition-tables/transition-tables.factor b/unfinished/regexp2/transition-tables/transition-tables.factor index 0547846655..32a65922f7 100644 --- a/unfinished/regexp2/transition-tables/transition-tables.factor +++ b/unfinished/regexp2/transition-tables/transition-tables.factor @@ -14,7 +14,7 @@ IN: regexp2.transition-tables : ?insert-at ( value key hash/f -- hash ) [ H{ } clone ] unless* [ insert-at ] keep ; -TUPLE: transition from to obj ; +TUPLE: transition from to obj lookahead ; TUPLE: literal-transition < transition ; TUPLE: class-transition < transition ; TUPLE: default-transition < transition ; @@ -22,9 +22,12 @@ TUPLE: default-transition < transition ; TUPLE: literal obj ; TUPLE: class obj ; TUPLE: default ; -: ( from to obj -- transition ) literal-transition boa ; -: ( from to obj -- transition ) class-transition boa ; -: ( from to -- transition ) t default-transition boa ; +: ( from to obj -- transition ) + f literal-transition boa ; +: ( from to obj -- transition ) + f class-transition boa ; +: ( from to -- transition ) + t f default-transition boa ; TUPLE: transition-table transitions literals classes defaults diff --git a/unfinished/regexp2/traversal/traversal.factor b/unfinished/regexp2/traversal/traversal.factor index 94e96bb935..a7a777043f 100644 --- a/unfinished/regexp2/traversal/traversal.factor +++ b/unfinished/regexp2/traversal/traversal.factor @@ -65,7 +65,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..9655d8ee03 100644 --- a/unfinished/regexp2/utils/utils.factor +++ b/unfinished/regexp2/utils/utils.factor @@ -10,7 +10,7 @@ IN: regexp2.utils ! 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 From ae8254c0fd12e070f552a5da8e66002bb8a86dc8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 27 Aug 2008 15:27:54 -0500 Subject: [PATCH 02/55] revert change to lookahead, parse negative lookahead correctly --- unfinished/regexp2/dfa/dfa.factor | 2 +- unfinished/regexp2/nfa/nfa.factor | 4 ++-- unfinished/regexp2/parser/parser.factor | 2 +- .../regexp2/transition-tables/transition-tables.factor | 8 ++++---- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/unfinished/regexp2/dfa/dfa.factor b/unfinished/regexp2/dfa/dfa.factor index 532ee130bc..0dcf6c4ab5 100644 --- a/unfinished/regexp2/dfa/dfa.factor +++ b/unfinished/regexp2/dfa/dfa.factor @@ -42,7 +42,7 @@ IN: regexp2.dfa dupd pop dup pick find-transitions rot [ [ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep - >r swapd f transition boa r> dfa-table>> add-transition + >r swapd transition boa r> dfa-table>> add-transition ] curry with each new-transitions ] if-empty ; diff --git a/unfinished/regexp2/nfa/nfa.factor b/unfinished/regexp2/nfa/nfa.factor index 1dada10d52..f87a2a7b52 100644 --- a/unfinished/regexp2/nfa/nfa.factor +++ b/unfinished/regexp2/nfa/nfa.factor @@ -30,10 +30,10 @@ GENERIC: nfa-node ( node -- ) stack [ regexp stack>> ] table [ regexp nfa-table>> ] | negated? [ - s0 f obj f class boa table add-transition + s0 f obj class boa table add-transition s0 s1 table add-transition ] [ - s0 s1 obj f class boa table add-transition + s0 s1 obj class boa table add-transition ] if s0 s1 2array stack push t s1 table final-states>> set-at ] ; diff --git a/unfinished/regexp2/parser/parser.factor b/unfinished/regexp2/parser/parser.factor index 39ca01e319..bd291f3cf7 100644 --- a/unfinished/regexp2/parser/parser.factor +++ b/unfinished/regexp2/parser/parser.factor @@ -155,7 +155,7 @@ DEFER: nested-parse-regexp [ 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 ] } diff --git a/unfinished/regexp2/transition-tables/transition-tables.factor b/unfinished/regexp2/transition-tables/transition-tables.factor index 32a65922f7..a9e67777fa 100644 --- a/unfinished/regexp2/transition-tables/transition-tables.factor +++ b/unfinished/regexp2/transition-tables/transition-tables.factor @@ -14,7 +14,7 @@ IN: regexp2.transition-tables : ?insert-at ( value key hash/f -- hash ) [ H{ } clone ] unless* [ insert-at ] keep ; -TUPLE: transition from to obj lookahead ; +TUPLE: transition from to obj ; TUPLE: literal-transition < transition ; TUPLE: class-transition < transition ; TUPLE: default-transition < transition ; @@ -23,11 +23,11 @@ TUPLE: literal obj ; TUPLE: class obj ; TUPLE: default ; : ( from to obj -- transition ) - f literal-transition boa ; + literal-transition boa ; : ( from to obj -- transition ) - f class-transition boa ; + class-transition boa ; : ( from to -- transition ) - t f default-transition boa ; + t default-transition boa ; TUPLE: transition-table transitions literals classes defaults From b912a7350989c1d1af5b447eb388aa38b358b183 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 27 Aug 2008 15:59:07 -0500 Subject: [PATCH 03/55] fix parser for special groups --- unfinished/regexp2/parser/parser.factor | 32 +++++++++++++------------ 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/unfinished/regexp2/parser/parser.factor b/unfinished/regexp2/parser/parser.factor index bd291f3cf7..206db3883d 100644 --- a/unfinished/regexp2/parser/parser.factor +++ b/unfinished/regexp2/parser/parser.factor @@ -151,6 +151,8 @@ 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: = = ] @@ -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 ] } - [ 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 ] } + [ 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 [ From d0e0c09124a1b2805d6b24f23dc3bf5e33e52855 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 27 Aug 2008 16:22:34 -0500 Subject: [PATCH 04/55] add flags slot to transitions, get rid of boa usage --- unfinished/regexp2/dfa/dfa.factor | 2 +- unfinished/regexp2/nfa/nfa.factor | 4 ++-- .../transition-tables/transition-tables.factor | 14 ++++++++++---- 3 files changed, 13 insertions(+), 7 deletions(-) diff --git a/unfinished/regexp2/dfa/dfa.factor b/unfinished/regexp2/dfa/dfa.factor index 0dcf6c4ab5..8d847b301f 100644 --- a/unfinished/regexp2/dfa/dfa.factor +++ b/unfinished/regexp2/dfa/dfa.factor @@ -42,7 +42,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 ; diff --git a/unfinished/regexp2/nfa/nfa.factor b/unfinished/regexp2/nfa/nfa.factor index f87a2a7b52..eb74aade35 100644 --- a/unfinished/regexp2/nfa/nfa.factor +++ b/unfinished/regexp2/nfa/nfa.factor @@ -30,10 +30,10 @@ 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 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 ] ; diff --git a/unfinished/regexp2/transition-tables/transition-tables.factor b/unfinished/regexp2/transition-tables/transition-tables.factor index a9e67777fa..c0c2d2e15c 100644 --- a/unfinished/regexp2/transition-tables/transition-tables.factor +++ b/unfinished/regexp2/transition-tables/transition-tables.factor @@ -14,7 +14,7 @@ IN: regexp2.transition-tables : ?insert-at ( value key hash/f -- hash ) [ H{ } clone ] unless* [ insert-at ] keep ; -TUPLE: transition from to obj ; +TUPLE: transition from to obj flags ; TUPLE: literal-transition < transition ; TUPLE: class-transition < transition ; TUPLE: default-transition < transition ; @@ -22,12 +22,18 @@ TUPLE: default-transition < transition ; TUPLE: literal obj ; TUPLE: class obj ; TUPLE: default ; +: make-transition ( from to obj class -- obj ) + new + swap >>obj + swap >>to + swap >>from + H{ } clone >>flags ; : ( from to obj -- transition ) - literal-transition boa ; + literal-transition make-transition ; : ( from to obj -- transition ) - class-transition boa ; + class-transition make-transition ; : ( from to -- transition ) - t default-transition boa ; + t default-transition make-transition ; TUPLE: transition-table transitions literals classes defaults From 5df8f491fa355ef729b5bcfc09dc539b814661a7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 27 Aug 2008 16:23:51 -0500 Subject: [PATCH 05/55] add unit test for regexp comments --- unfinished/regexp2/regexp2-tests.factor | 2 ++ 1 file changed, 2 insertions(+) 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 drop ] unit-test +! Comment +[ t ] [ "ac" "a(?#boo)c" matches? ] unit-test From 97599d707b42d5efa21c89172dfa05f6cea2b70e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Aug 2008 13:45:04 -0500 Subject: [PATCH 06/55] moved a few util words around added traversal-flags --- unfinished/regexp2/backend/backend.factor | 1 + unfinished/regexp2/nfa/nfa.factor | 20 +++++++++++++++- unfinished/regexp2/regexp2.factor | 4 +++- .../transition-tables.factor | 24 +++++-------------- unfinished/regexp2/traversal/traversal.factor | 15 +++++++----- unfinished/regexp2/utils/utils.factor | 16 ++++++++++++- 6 files changed, 53 insertions(+), 27 deletions(-) diff --git a/unfinished/regexp2/backend/backend.factor b/unfinished/regexp2/backend/backend.factor index c39d67e7b8..de1546fdd3 100644 --- a/unfinished/regexp2/backend/backend.factor +++ b/unfinished/regexp2/backend/backend.factor @@ -11,6 +11,7 @@ TUPLE: regexp nfa-table dfa-table minimized-table + { traversal-flags hashtable } { state integer } { new-states vector } { visited-states hashtable } ; diff --git a/unfinished/regexp2/nfa/nfa.factor b/unfinished/regexp2/nfa/nfa.factor index eb74aade35..eaedbcc5b1 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 ; @@ -38,6 +44,10 @@ GENERIC: nfa-node ( node -- ) s0 s1 2array stack push t s1 table final-states>> set-at ] ; +: add-traversal-flag ( flag -- ) + stack peek second + current-regexp get 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/regexp2.factor b/unfinished/regexp2/regexp2.factor index 0b8994ca2b..9413287e6c 100644 --- a/unfinished/regexp2/regexp2.factor +++ b/unfinished/regexp2/regexp2.factor @@ -12,6 +12,7 @@ IN: regexp2 >>nfa-table >>dfa-table >>minimized-table + H{ } clone >>traversal-flags reset-regexp ; : construct-regexp ( regexp -- regexp' ) @@ -26,7 +27,8 @@ IN: regexp2 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 c0c2d2e15c..c67985af4a 100644 --- a/unfinished/regexp2/transition-tables/transition-tables.factor +++ b/unfinished/regexp2/transition-tables/transition-tables.factor @@ -1,20 +1,10 @@ ! 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 flags ; +TUPLE: transition from to obj ; TUPLE: literal-transition < transition ; TUPLE: class-transition < transition ; TUPLE: default-transition < transition ; @@ -26,8 +16,8 @@ TUPLE: default ; new swap >>obj swap >>to - swap >>from - H{ } clone >>flags ; + swap >>from ; + : ( from to obj -- transition ) literal-transition make-transition ; : ( from to obj -- transition ) @@ -35,9 +25,7 @@ TUPLE: default ; : ( from to -- transition ) t default-transition make-transition ; -TUPLE: transition-table transitions - literals classes defaults - start-state final-states ; +TUPLE: transition-table transitions start-state final-states ; : ( -- transition-table ) transition-table new @@ -45,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 a7a777043f..1a4d166cea 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 ; : ( 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 @@ -49,9 +55,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 diff --git a/unfinished/regexp2/utils/utils.factor b/unfinished/regexp2/utils/utils.factor index 9655d8ee03..48c68d883f 100644 --- a/unfinished/regexp2/utils/utils.factor +++ b/unfinished/regexp2/utils/utils.factor @@ -3,7 +3,7 @@ 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 ) @@ -15,6 +15,20 @@ IN: regexp2.utils : 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 ; From 61122e6e9f85b77bdc8e9e66c4835dc815c34f76 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Aug 2008 22:08:54 -0500 Subject: [PATCH 07/55] more work on traversal-flags --- unfinished/regexp2/backend/backend.factor | 3 ++- unfinished/regexp2/dfa/dfa.factor | 13 +++++++++++-- unfinished/regexp2/nfa/nfa.factor | 2 +- unfinished/regexp2/regexp2.factor | 3 ++- unfinished/regexp2/traversal/traversal.factor | 3 +-- 5 files changed, 17 insertions(+), 7 deletions(-) diff --git a/unfinished/regexp2/backend/backend.factor b/unfinished/regexp2/backend/backend.factor index de1546fdd3..81ffb334bd 100644 --- a/unfinished/regexp2/backend/backend.factor +++ b/unfinished/regexp2/backend/backend.factor @@ -11,7 +11,8 @@ TUPLE: regexp nfa-table dfa-table minimized-table - { traversal-flags hashtable } + { 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 8d847b301f..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 @@ -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 eaedbcc5b1..792d9fe30f 100644 --- a/unfinished/regexp2/nfa/nfa.factor +++ b/unfinished/regexp2/nfa/nfa.factor @@ -46,7 +46,7 @@ GENERIC: nfa-node ( node -- ) : add-traversal-flag ( flag -- ) stack peek second - current-regexp get traversal-flags>> push-at ; + current-regexp get nfa-traversal-flags>> push-at ; :: concatenate-nodes ( -- ) [let* | regexp [ current-regexp get ] diff --git a/unfinished/regexp2/regexp2.factor b/unfinished/regexp2/regexp2.factor index 9413287e6c..efc5c660de 100644 --- a/unfinished/regexp2/regexp2.factor +++ b/unfinished/regexp2/regexp2.factor @@ -12,7 +12,8 @@ IN: regexp2 >>nfa-table >>dfa-table >>minimized-table - H{ } clone >>traversal-flags + H{ } clone >>nfa-traversal-flags + H{ } clone >>dfa-traversal-flags reset-regexp ; : construct-regexp ( regexp -- regexp' ) diff --git a/unfinished/regexp2/traversal/traversal.factor b/unfinished/regexp2/traversal/traversal.factor index 1a4d166cea..a5db2cdaa8 100644 --- a/unfinished/regexp2/traversal/traversal.factor +++ b/unfinished/regexp2/traversal/traversal.factor @@ -45,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 ) From 3eae1ffe4b0e32ed3d4e3fe9c7612cee656b64ff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Aug 2008 23:19:18 -0500 Subject: [PATCH 08/55] add docs move some words to private --- basis/smtp/smtp-docs.factor | 46 +++++++++++++++++++++++++++++++++++++ basis/smtp/smtp.factor | 12 +++++----- 2 files changed, 52 insertions(+), 6 deletions(-) create mode 100644 basis/smtp/smtp-docs.factor diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor new file mode 100644 index 0000000000..cf5dbfe94b --- /dev/null +++ b/basis/smtp/smtp-docs.factor @@ -0,0 +1,46 @@ +! 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: +{ $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 + { $example "" + " \"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 } +"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.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" 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 new ; +" ?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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 8cd2f34db435f9c87d0b468d1081940230f74798 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Aug 2008 23:19:51 -0500 Subject: [PATCH 09/55] spacing --- basis/smtp/smtp-docs.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor index cf5dbfe94b..618cf5f836 100644 --- a/basis/smtp/smtp-docs.factor +++ b/basis/smtp/smtp-docs.factor @@ -41,6 +41,4 @@ ARTICLE: "smtp" "SMTP Client Library" "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 - -; +"Set the " { $snippet "body" } " to a " { $link string } "." $nl ; From 98fafecaa7f49f528e285f2c6f3b60b334bbd74c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Aug 2008 23:22:53 -0500 Subject: [PATCH 10/55] add license line, IN: --- basis/base64/base64-tests.factor | 1 + basis/base64/base64.factor | 2 ++ 2 files changed, 3 insertions(+) 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 From e91129ba102ac7fd953b25ce10949c778e2d2f50 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Aug 2008 23:42:59 -0500 Subject: [PATCH 11/55] make alarms use new accessors --- basis/alarms/alarms.factor | 41 +++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 20 deletions(-) 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 } ; ( quot time frequency -- alarm ) check-alarm 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? ; From cb4e9f2f770387a59539569e7350884f596c6ecd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 00:00:41 -0500 Subject: [PATCH 12/55] document alias --- basis/alias/alias-docs.factor | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 basis/alias/alias-docs.factor diff --git a/basis/alias/alias-docs.factor b/basis/alias/alias-docs.factor new file mode 100644 index 0000000000..024c6ea491 --- /dev/null +++ b/basis/alias/alias-docs.factor @@ -0,0 +1,15 @@ +USING: kernel words help.markup help.syntax ; +IN: alias + +HELP: ALIAS: +{ $syntax "ALIAS: new-word existing-word" } +{ $values { "new-word" word } { "existing-word" word } } +{ $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." } +{ $examples + { $example "ALIAS: sequence-nth nth" + "0 { 10 20 30 } sequence-nth" + "10" + } +} ; + + From 98bbf464a2d9efbcd7567ee1a0c18e1e14a16681 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 00:30:13 -0500 Subject: [PATCH 13/55] use 1|| in ascii vocab --- basis/ascii/ascii.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) 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|| ; From 39940f793dd705555aed6adc6d9f984569ba16cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 00:34:22 -0500 Subject: [PATCH 14/55] change literal string throw to ERROR: --- basis/biassocs/biassocs.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) 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 ; From d4d236441b941b2f659977892c914201aeb42e3c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 00:37:23 -0500 Subject: [PATCH 15/55] add missing using --- basis/bootstrap/handbook/handbook.factor | 1 + 1 file changed, 1 insertion(+) 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 From 4272938b6331a434a1008aedf046e6d2ae8a9370 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 00:41:26 -0500 Subject: [PATCH 16/55] add IN: --- basis/bootstrap/random/random.factor | 1 + basis/bootstrap/tools/tools.factor | 1 + basis/bootstrap/ui/ui.factor | 1 + basis/bootstrap/unicode/unicode.factor | 1 + 4 files changed, 4 insertions(+) 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 From 4f8bc90ccaa0087bdcf5d777184aa52c665c17f5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 00:52:00 -0500 Subject: [PATCH 17/55] remove old accessors from cocoa --- basis/cocoa/messages/messages.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) 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: ( 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 From 92fe9cfb454de6998e125db698699bc091d78b33 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 01:00:39 -0500 Subject: [PATCH 18/55] use new accessors, throw -> ERROR: --- basis/concurrency/messaging/messaging.factor | 12 ++++++------ .../concurrency/semaphores/semaphores.factor | 19 ++++++++++++------- 2 files changed, 18 insertions(+), 13 deletions(-) diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index e77760408c..810e4430f1 100755 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -4,7 +4,7 @@ ! Concurrency library for Factor, based on Erlang/Termite style ! concurrency. USING: kernel threads concurrency.mailboxes continuations -namespaces assocs random ; +namespaces assocs random accessors ; IN: concurrency.messaging GENERIC: send ( message thread -- ) @@ -45,11 +45,11 @@ TUPLE: synchronous data sender tag ; TUPLE: reply data tag ; : ( 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 dup r> send [ synchronous-reply? ] curry receive-if - reply-data + data>> ] if ; : reply-synchronous ( message synchronous -- ) - [ ] keep synchronous-sender send ; + [ ] keep sender>> send ; : handle-synchronous ( quot -- ) receive [ - synchronous-data swap call + data>> swap call ] keep reply-synchronous ; inline ( n -- semaphore ) - dup 0 < [ "Cannot have semaphore with negative count" throw ] when + dup 0 < [ negative-count-semaphore ] when 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 From 475a96dcb7b237ec71dcacfb5cac0ae6b504038e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 01:53:34 -0500 Subject: [PATCH 19/55] new accessors in promises --- extra/promises/promises.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) 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 ) [ From 144f79ffabe5cd0818a1a71fc87e672500ece9e9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 01:59:25 -0500 Subject: [PATCH 20/55] use ERROR: instead of throwing strings --- basis/mirrors/mirrors.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) 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 From a5baa31784a0576aa85f43abe9e166a9f6eafc0b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 02:13:08 -0500 Subject: [PATCH 21/55] new accessors --- basis/documents/documents.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 ; From 42bd621cce31af36723e17bc58cc45a96bbc933d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 02:13:27 -0500 Subject: [PATCH 22/55] ERROR: instead of throw --- basis/heaps/heaps.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 1873db67b5..bb110bbf20 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 ) @@ -161,10 +161,13 @@ 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 + over entry-heap eq? [ bad-heap-delete ] unless entry-index ; M: heap heap-delete ( entry heap -- ) From 99a79bb0809476e8c8c856e7bccab9a590311f0e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 02:14:01 -0500 Subject: [PATCH 23/55] new accessors --- basis/help/markup/markup.factor | 4 ++-- basis/help/topics/topics.factor | 20 +++++++++----------- 2 files changed, 11 insertions(+), 13 deletions(-) diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index e3cefb7992..d480a44a67 100755 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -143,13 +143,13 @@ M: f print-element drop ; link-style get [ write-object ] with-style ; : ($link) ( article -- ) - [ dup article-name swap >link write-link ] ($span) ; + [ [ name>> ] [ >link ] bi write-link ] ($span) ; : $link ( element -- ) first ($link) ; : ($long-link) ( object -- ) - dup article-title swap >link write-link ; + dup title>> swap >link write-link ; : ($subsection) ( element quot -- ) [ 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 ; From e7167b47dbc4fe518c3a4f1e10aebfba51d367f4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 02:14:14 -0500 Subject: [PATCH 24/55] new accessors --- basis/memoize/memoize.factor | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) 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 From 80f67f1ca716cdcf1956b89cad019952d24e0a97 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 02:14:22 -0500 Subject: [PATCH 25/55] new accessors --- basis/locals/locals.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index a0b667e44b..bc05814348 100755 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -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 ; M: lambda-method synopsis* From 304c713954a5ae9b8ffb2c8174d9b67378f0f10f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:12:24 -0500 Subject: [PATCH 26/55] Revert "new accessors" This reverts commit 99a79bb0809476e8c8c856e7bccab9a590311f0e. --- basis/help/markup/markup.factor | 4 ++-- basis/help/topics/topics.factor | 20 +++++++++++--------- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index d480a44a67..e3cefb7992 100755 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -143,13 +143,13 @@ M: f print-element drop ; link-style get [ write-object ] with-style ; : ($link) ( article -- ) - [ [ name>> ] [ >link ] bi write-link ] ($span) ; + [ dup article-name swap >link write-link ] ($span) ; : $link ( element -- ) first ($link) ; : ($long-link) ( object -- ) - dup title>> swap >link write-link ; + dup article-title swap >link write-link ; : ($subsection) ( element quot -- ) [ diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index 14a6c3f8ad..6ad3b23c2c 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: accessors arrays definitions generic assocs +USING: 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 name>> word? ; +PREDICATE: word-link < link link-name word? ; M: link summary [ "Link: " % - name>> dup word? [ summary ] [ unparse ] if % + link-name dup word? [ summary ] [ unparse ] if % ] "" make ; ! Help articles @@ -44,7 +44,9 @@ TUPLE: article title content loc ; M: article article-name article-title ; -ERROR: no-article name ; +TUPLE: no-article name ; + +: no-article ( name -- * ) \ no-article boa throw ; M: no-article summary drop "Help article does not exist" ; @@ -58,11 +60,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 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 ; +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 ; ! Special case: f help M: f article-name drop \ f article-name ; From 524bce2dd2b4bc331db03ed8495d021d977852d2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:14:16 -0500 Subject: [PATCH 27/55] Revert "make alarms use new accessors" This reverts commit e91129ba102ac7fd953b25ce10949c778e2d2f50. --- basis/alarms/alarms.factor | 41 +++++++++++++++++++------------------- 1 file changed, 20 insertions(+), 21 deletions(-) diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index cbbebde579..a72960f20f 100755 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -1,15 +1,11 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays calendar combinators generic init -kernel math namespaces sequences heaps boxes threads debugger -quotations assocs math.order ; +USING: arrays calendar combinators generic init kernel math +namespaces sequences heaps boxes threads debugger quotations +assocs math.order ; IN: alarms -TUPLE: alarm - { quot callable initial: [ ] } - { time timestamp } - interval - { entry box } ; +TUPLE: alarm quot time interval entry ; ( quot time frequency -- alarm ) check-alarm alarm boa ; : register-alarm ( alarm -- ) - dup dup time>> alarms get-global heap-push* - swap entry>> >box + dup dup alarm-time alarms get-global heap-push* + swap alarm-entry >box notify-alarm-thread ; : alarm-expired? ( alarm now -- ? ) - [ time>> ] dip before=? ; + >r alarm-time r> before=? ; : reschedule-alarm ( alarm -- ) - dup [ swap interval>> time+ ] change-time register-alarm ; + dup alarm-time over alarm-interval time+ + over set-alarm-time + register-alarm ; : call-alarm ( alarm -- ) - [ entry>> box> drop ] - [ quot>> "Alarm execution" spawn drop ] - [ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ; + dup alarm-entry box> drop + dup alarm-quot "Alarm execution" spawn drop + dup alarm-interval [ reschedule-alarm ] [ drop ] if ; : (trigger-alarms) ( alarms now -- ) over heap-empty? [ @@ -58,7 +57,7 @@ ERROR: bad-alarm-frequency frequency ; : next-alarm ( alarms -- timestamp/f ) dup heap-empty? - [ drop f ] [ heap-peek drop time>> ] if ; + [ drop f ] [ heap-peek drop alarm-time ] if ; : alarm-thread-loop ( -- ) alarms get-global @@ -67,7 +66,7 @@ ERROR: bad-alarm-frequency frequency ; : cancel-alarms ( alarms -- ) [ - heap-pop-all [ nip entry>> box> drop ] assoc-each + heap-pop-all [ nip alarm-entry box> drop ] assoc-each ] when* ; : init-alarms ( -- ) @@ -89,4 +88,4 @@ PRIVATE> [ hence ] keep add-alarm ; : cancel-alarm ( alarm -- ) - entry>> [ alarms get-global heap-delete ] if-box? ; + alarm-entry [ alarms get-global heap-delete ] if-box? ; From e0810c727d753af47671dd03926a10f035054595 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:14:34 -0500 Subject: [PATCH 28/55] Revert "remove old accessors from cocoa" This reverts commit 4f8bc90ccaa0087bdcf5d777184aa52c665c17f5. --- basis/cocoa/messages/messages.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index ea7280b5a6..94c5f05887 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: accessors alien alien.c-types alien.strings +USING: 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: ( name -- sel ) f \ selector boa ; : selector ( selector -- alien ) - dup object>> expired? [ - dup name>> sel_registerName - [ >>object drop ] keep + dup selector-object expired? [ + dup selector-name sel_registerName + dup rot set-selector-object ] [ - object>> + selector-object ] if ; SYMBOL: objc-methods From 313b5c28210a5210fee4ba92af740591927aa03f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:24:22 -0500 Subject: [PATCH 29/55] new accessors --- basis/cocoa/messages/messages.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) 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: ( 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 From 28526eb31557bd2ed557d5d9c9e0873a89e1c210 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:26:14 -0500 Subject: [PATCH 30/55] new accessors --- basis/help/topics/topics.factor | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) 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 ; From c1bd4a7cddf66f2618de07d9453a8147faedec73 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:26:34 -0500 Subject: [PATCH 31/55] new accessors, cleanups --- basis/alarms/alarms.factor | 41 +++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 20 deletions(-) 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 } ; ( quot time frequency -- alarm ) check-alarm 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? ; From eb5e72c7d3439d51f067abd51cdeb003c3e616e7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:26:53 -0500 Subject: [PATCH 32/55] new accessors --- basis/tools/annotations/annotations.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 ; From b839f608d0a50bfc0584ba588203eb58f4929e8b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:27:31 -0500 Subject: [PATCH 33/55] new accessors --- basis/io/buffers/buffers-docs.factor | 4 ++-- basis/io/launcher/launcher.factor | 21 +++++++++++++++------ basis/macros/macros.factor | 6 +++--- basis/prettyprint/prettyprint-tests.factor | 5 +++-- 4 files changed, 23 insertions(+), 13 deletions(-) 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: 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/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 ; + "declared-effect" word-prop in>> 1 ; : 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/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 ] [ From f85493e980584a1739ada11aef2f46c2cfbeaf62 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:28:01 -0500 Subject: [PATCH 34/55] new accessors --- extra/inverse/inverse.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) 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 ; From c6b28c0b3fddee08c77868ba30a682c622e4aa45 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:29:11 -0500 Subject: [PATCH 35/55] new accessors --- basis/alien/c-types/c-types.factor | 44 ++++++++++++++++++------------ basis/alien/strings/strings.factor | 6 ++-- 2 files changed, 29 insertions(+), 21 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index a9b39f80ab..5184a06bc2 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations ; +accessors combinators effects continuations summary ; IN: alien.c-types DEFER: @@ -62,17 +62,19 @@ M: string c-type ( name -- type ) ] ?if ] if ; +ERROR: no-boxer ; +M: no-boxer summary drop "No boxer" ; : c-type-box ( n type -- ) - dup c-type-reg-class - swap c-type-boxer [ "No boxer" throw ] unless* - %box ; + [ reg-class>> ] + [ boxer>> [ no-boxer ] unless* ] bi %box ; +ERROR: no-unboxer ; +M: no-unboxer summary drop "No unboxer" ; : c-type-unbox ( n ctype -- ) - dup c-type-reg-class - swap c-type-unboxer [ "No unboxer" throw ] unless* - %unbox ; + [ reg-class>> ] + [ unboxer>> [ no-unboxer ] unless* ] bi %unbox ; -M: string c-type-align c-type c-type-align ; +M: string c-type-align c-type align>> ; M: string c-type-stack-align? c-type c-type-stack-align? ; @@ -107,27 +109,33 @@ GENERIC: heap-size ( type -- size ) foldable M: string heap-size c-type heap-size ; -M: c-type heap-size c-type-size ; +M: c-type heap-size size>> ; GENERIC: stack-size ( type -- size ) foldable M: string stack-size c-type stack-size ; -M: c-type stack-size c-type-size ; +M: c-type stack-size size>> ; GENERIC: byte-length ( seq -- n ) flushable M: byte-array byte-length length ; +ERROR: c-struct-reader ; + +M: c-struct-reader summary + drop "Cannot read struct fields with type" ; + : c-getter ( name -- quot ) - c-type c-type-getter [ - [ "Cannot read struct fields with type" throw ] - ] unless* ; + c-type c-type-getter [ c-struct-reader ] unless* ; + +ERROR: c-struct-writer ; + +M: c-struct-writer summary + drop "Cannot write struct fields with type" ; : c-setter ( name -- quot ) - c-type c-type-setter [ - [ "Cannot write struct fields with type" throw ] - ] unless* ; + c-type c-type-setter [ c-struct-writer ] unless* ; : ( n type -- array ) heap-size * ; inline @@ -178,13 +186,13 @@ TUPLE: long-long-type < c-type ; long-long-type new-c-type ; M: long-long-type unbox-parameter ( n type -- ) - c-type-unboxer %unbox-long-long ; + unboxer>> %unbox-long-long ; M: long-long-type unbox-return ( type -- ) f swap unbox-parameter ; M: long-long-type box-parameter ( n type -- ) - c-type-boxer %box-long-long ; + boxer>> %box-long-long ; M: long-long-type box-return ( type -- ) f swap box-parameter ; diff --git a/basis/alien/strings/strings.factor b/basis/alien/strings/strings.factor index 70bbe773ee..ceddb8407e 100755 --- a/basis/alien/strings/strings.factor +++ b/basis/alien/strings/strings.factor @@ -44,7 +44,7 @@ M: string-type heap-size drop "void*" heap-size ; M: string-type c-type-align - drop "void*" c-type-align ; + drop "void*" align>> ; M: string-type c-type-stack-align? drop "void*" c-type-stack-align? ; @@ -68,10 +68,10 @@ M: string-type c-type-reg-class drop int-regs ; M: string-type c-type-boxer - drop "void*" c-type-boxer ; + drop "void*" boxer>> ; M: string-type c-type-unboxer - drop "void*" c-type-unboxer ; + drop "void*" unboxer>> ; M: string-type c-type-boxer-quot second [ alien>string ] curry [ ] like ; From 90bc1bc0b57e95c6c3d3fb8e25517f7625815842 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:37:07 -0500 Subject: [PATCH 36/55] use new accessor --- core/classes/algebra/algebra-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) 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 From 95d1f808cd84e98db06108f7f2016ade991090b2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 10:43:43 -0500 Subject: [PATCH 37/55] Revert "new accessors" This reverts commit c6b28c0b3fddee08c77868ba30a682c622e4aa45. --- basis/alien/c-types/c-types.factor | 44 ++++++++++++------------------ basis/alien/strings/strings.factor | 6 ++-- 2 files changed, 21 insertions(+), 29 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 5184a06bc2..a9b39f80ab 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations summary ; +accessors combinators effects continuations ; IN: alien.c-types DEFER: @@ -62,19 +62,17 @@ M: string c-type ( name -- type ) ] ?if ] if ; -ERROR: no-boxer ; -M: no-boxer summary drop "No boxer" ; : c-type-box ( n type -- ) - [ reg-class>> ] - [ boxer>> [ no-boxer ] unless* ] bi %box ; + dup c-type-reg-class + swap c-type-boxer [ "No boxer" throw ] unless* + %box ; -ERROR: no-unboxer ; -M: no-unboxer summary drop "No unboxer" ; : c-type-unbox ( n ctype -- ) - [ reg-class>> ] - [ unboxer>> [ no-unboxer ] unless* ] bi %unbox ; + dup c-type-reg-class + swap c-type-unboxer [ "No unboxer" throw ] unless* + %unbox ; -M: string c-type-align c-type align>> ; +M: string c-type-align c-type c-type-align ; M: string c-type-stack-align? c-type c-type-stack-align? ; @@ -109,33 +107,27 @@ GENERIC: heap-size ( type -- size ) foldable M: string heap-size c-type heap-size ; -M: c-type heap-size size>> ; +M: c-type heap-size c-type-size ; GENERIC: stack-size ( type -- size ) foldable M: string stack-size c-type stack-size ; -M: c-type stack-size size>> ; +M: c-type stack-size c-type-size ; GENERIC: byte-length ( seq -- n ) flushable M: byte-array byte-length length ; -ERROR: c-struct-reader ; - -M: c-struct-reader summary - drop "Cannot read struct fields with type" ; - : c-getter ( name -- quot ) - c-type c-type-getter [ c-struct-reader ] unless* ; - -ERROR: c-struct-writer ; - -M: c-struct-writer summary - drop "Cannot write struct fields with type" ; + c-type c-type-getter [ + [ "Cannot read struct fields with type" throw ] + ] unless* ; : c-setter ( name -- quot ) - c-type c-type-setter [ c-struct-writer ] unless* ; + c-type c-type-setter [ + [ "Cannot write struct fields with type" throw ] + ] unless* ; : ( n type -- array ) heap-size * ; inline @@ -186,13 +178,13 @@ TUPLE: long-long-type < c-type ; long-long-type new-c-type ; M: long-long-type unbox-parameter ( n type -- ) - unboxer>> %unbox-long-long ; + c-type-unboxer %unbox-long-long ; M: long-long-type unbox-return ( type -- ) f swap unbox-parameter ; M: long-long-type box-parameter ( n type -- ) - boxer>> %box-long-long ; + c-type-boxer %box-long-long ; M: long-long-type box-return ( type -- ) f swap box-parameter ; diff --git a/basis/alien/strings/strings.factor b/basis/alien/strings/strings.factor index ceddb8407e..70bbe773ee 100755 --- a/basis/alien/strings/strings.factor +++ b/basis/alien/strings/strings.factor @@ -44,7 +44,7 @@ M: string-type heap-size drop "void*" heap-size ; M: string-type c-type-align - drop "void*" align>> ; + drop "void*" c-type-align ; M: string-type c-type-stack-align? drop "void*" c-type-stack-align? ; @@ -68,10 +68,10 @@ M: string-type c-type-reg-class drop int-regs ; M: string-type c-type-boxer - drop "void*" boxer>> ; + drop "void*" c-type-boxer ; M: string-type c-type-unboxer - drop "void*" unboxer>> ; + drop "void*" c-type-unboxer ; M: string-type c-type-boxer-quot second [ alien>string ] curry [ ] like ; From 5f126677885bdcd5ed93d29a1ef2522bd743d9bb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 12:00:54 -0500 Subject: [PATCH 38/55] new accessors --- basis/compiler/tests/alien.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 From 24bfa90a04f25e04bb552de9b8cdaaec0aaaeb98 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 15:17:15 -0500 Subject: [PATCH 39/55] refactor calendar a bit, add initial docs --- basis/calendar/calendar-docs.factor | 31 +++++++++++ basis/calendar/calendar.factor | 86 +++++++++++++++++++++-------- basis/calendar/format/format.factor | 12 ++-- 3 files changed, 100 insertions(+), 29 deletions(-) create mode 100644 basis/calendar/calendar-docs.factor diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor new file mode 100644 index 0000000000..0d335d1b41 --- /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: +{ $values { "year" real } { "month" real } { "day" real } } +{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." } +{ $examples + { $example "USE: calendar" + "12 25 2010 ." + "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 - -TUPLE: duration year month day hour minute second ; +TUPLE: duration + { year real } + { month real } + { day real } + { hour real } + { minute real } + { second real } ; C: duration +TUPLE: timestamp + { year integer } + { month integer } + { day integer } + { hour integer } + { minute integer } + { second real } + { gmt-offset duration } ; + +C: timestamp + : gmt-offset-duration ( -- duration ) 0 0 0 gmt-offset ; : ( year month day -- timestamp ) 0 0 0 gmt-offset-duration ; -: month-names +ERROR: not-a-month n ; +M: not-a-month summary + drop "Months are indexed starting at 1" ; + + + +: 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..36849d4ae3 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 " " 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 From 681d7e962c367f3b2f372bf184df4b4331b08bd3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 15:19:41 -0500 Subject: [PATCH 40/55] fix calendar docs --- basis/calendar/calendar-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 0d335d1b41..19427b7c79 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -17,12 +17,12 @@ HELP: gmt-offset-duration { $description "Returns a " { $link duration } " object with the GMT offset returned by " { $link gmt-offset } "." } ; HELP: -{ $values { "year" real } { "month" real } { "day" real } } +{ $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 "USE: calendar" + { $example "USING: calendar prettyprint ;" "12 25 2010 ." - "T{ timestamp f 12 25 2010 0 0 0 T{ duration f 0 0 0 -5 0 0 }" + "T{ timestamp f 12 25 2010 0 0 0 T{ duration f 0 0 0 -5 0 0 } }" } } ; From 57d2e5d8a81c01029638e16590248cb54d72cb43 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 15:49:23 -0500 Subject: [PATCH 41/55] remove accessor --- core/alien/alien.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 -- ) swap libraries get set-at ; From 235cf7e1b8d579dddf7ffb58e9c27fbd30e6203c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Aug 2008 15:51:52 -0500 Subject: [PATCH 42/55] new accessors --- basis/compiler/generator/fixup/fixup.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/compiler/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor index e1b4e42e67..c1275f8b5a 100755 --- a/basis/compiler/generator/fixup/fixup.factor +++ b/basis/compiler/generator/fixup/fixup.factor @@ -29,7 +29,7 @@ TUPLE: label offset ; :