diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 4a984f2fc5..8926f557e5 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,17 +1,13 @@ + 0.84: - declaration to do: - - move effect class to words vocab - - stack-effect word in words needs to be fixed - test what is done in the case of an invalid declaration on an inline recursive - - see should show declared effects - - get rid of the string "stack-effect" prop - HELP: should not specify stack effect - bootstrap speedup with compiling recursives - load cocoa before 'recompile' call - document inference errors - - maybe we can remove | + - update docs for declared effects - RT_WORD should refer to XTs not word objects. - fix contribs: boids, automata - sometimes darcs get fails with the httpd diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index f56fe9f229..e7f2e16b8d 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -65,6 +65,7 @@ sequences vectors words ; "/library/definitions.factor" "/library/words.factor" + "/library/effects.factor" "/library/continuations.factor" "/library/errors.factor" diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 9a57e8d13b..9b4665fe6e 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -187,7 +187,6 @@ M: f ' [ % dup word-vocabulary % " " % word-name % ] "" make throw ; : transfer-word ( word -- word ) - #! This is a hack. See doc/bootstrap.txt. dup target-word [ ] [ "Missing DEFER: " word-error ] ?if ; : fixup-word ( word -- offset ) diff --git a/library/collections/graphs.factor b/library/collections/graphs.factor index 11865cad00..9f73b0bcc4 100644 --- a/library/collections/graphs.factor +++ b/library/collections/graphs.factor @@ -5,13 +5,13 @@ USING: hashtables kernel namespaces sequences ; : if-graph over [ bind ] [ 2drop 2drop ] if ; inline -: (add-vertex) ( vertex edges -- | edges: vertex -- seq ) +: (add-vertex) ( vertex edges -- ) dupd call [ dupd nest set-hash ] each-with ; inline -: add-vertex ( vertex edges graph -- | edges: vertex -- seq ) +: add-vertex ( vertex edges graph -- ) [ (add-vertex) ] if-graph ; inline -: build-graph ( seq edges graph -- | edges: vertex -- seq ) +: build-graph ( seq edges graph -- ) [ namespace clear-hash swap [ swap (add-vertex) ] each-with @@ -37,7 +37,7 @@ SYMBOL: previous [ call ] keep swap [ swap (closure) ] each-with ] if ; inline -: closure ( obj quot -- seq | quot: obj -- seq ) +: closure ( obj quot -- seq ) [ H{ } clone previous set (closure) diff --git a/library/collections/growable.factor b/library/collections/growable.factor index 0bcdbd5354..7dcd16af14 100644 --- a/library/collections/growable.factor +++ b/library/collections/growable.factor @@ -6,9 +6,9 @@ IN: sequences-internals USING: errors kernel kernel-internals math math-internals sequences ; -GENERIC: underlying -GENERIC: set-underlying -GENERIC: set-fill +GENERIC: underlying ( seq -- underlying ) +GENERIC: set-underlying ( underlying seq -- ) +GENERIC: set-fill ( n seq -- ) : capacity ( seq -- n ) underlying length ; inline diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index 7238b80a99..eef73da223 100644 --- a/library/collections/hashtables.factor +++ b/library/collections/hashtables.factor @@ -30,7 +30,7 @@ TUPLE: tombstone ; : key@ ( key hash -- n ) hash-array 2dup hash@ (key@) ; inline -: if-key ( key hash true false -- ) | true ( index key hash -- ) +: if-key ( key hash true false -- ) >r >r [ key@ ] 2keep pick -1 > r> r> if ; inline : ( n -- array ) @@ -77,7 +77,7 @@ TUPLE: tombstone ; [ hash-array 2dup array-nth ] keep swap change-size set-nth-pair ; inline -: (each-pair) ( quot array i -- ) | quot ( k v -- ) +: (each-pair) ( quot array i -- ) over array-capacity over eq? [ 3drop ] [ @@ -87,10 +87,10 @@ TUPLE: tombstone ; ] 3keep 2 fixnum+fast (each-pair) ] if ; inline -: each-pair ( array quot -- ) | quot ( k v -- ) +: each-pair ( array quot -- ) swap 0 (each-pair) ; inline -: (all-pairs?) ( quot array i -- ? ) | quot ( k v -- ? ) +: (all-pairs?) ( quot array i -- ? ) over array-capacity over eq? [ 3drop t ] [ @@ -105,7 +105,7 @@ TUPLE: tombstone ; ] if ] if ; inline -: all-pairs? ( array quot -- ? ) | quot ( k v -- ? ) +: all-pairs? ( array quot -- ? ) swap 0 (all-pairs?) ; inline : hash>seq ( i hash -- seq ) @@ -188,17 +188,17 @@ IN: hashtables [ length ] keep [ first2 swap pick (set-hash) ] each ; -: hash-each ( hash quot -- ) | quot ( k v -- ) +: hash-each ( hash quot -- ) >r hash-array r> each-pair ; inline -: hash-each-with ( obj hash quot -- ) | quot ( obj k v -- ) +: hash-each-with ( obj hash quot -- ) swap [ 2swap [ >r -rot r> call ] 2keep ] hash-each 2drop ; inline -: hash-all? ( hash quot -- ) | quot ( k v -- ? ) +: hash-all? ( hash quot -- ) >r hash-array r> all-pairs? ; inline -: hash-all-with? ( obj hash quot -- ) | quot ( obj k v -- ? ) +: hash-all-with? ( obj hash quot -- ) swap [ 2swap [ >r -rot r> call ] 2keep rot ] hash-all? 2nip ; inline @@ -208,7 +208,7 @@ IN: hashtables >r swap hash* [ r> = ] [ r> 2drop f ] if ] hash-all-with? ; -: hash-subset ( hash quot -- hash ) | quot ( k v -- ? ) +: hash-subset ( hash quot -- hash ) over hash-size rot [ 2swap [ >r pick pick >r >r call [ @@ -219,7 +219,7 @@ IN: hashtables ] 2keep ] hash-each nip ; inline -: hash-subset-with ( obj hash quot -- hash ) | quot ( obj pair -- ? ) +: hash-subset-with ( obj hash quot -- hash ) swap [ 2swap [ >r -rot r> call ] 2keep rot ] hash-subset 2nip ; inline @@ -292,14 +292,14 @@ IN: hashtables : remove-all ( hash seq -- seq ) [ swap hash-member? not ] subset-with ; -: cache ( key hash quot -- value ) | quot ( key -- value ) +: cache ( key hash quot -- value ) pick pick hash [ >r 3drop r> ] [ pick rot >r >r call dup r> r> set-hash ] if* ; inline -: map>hash ( seq quot -- hash ) | quot ( key -- key value ) +: map>hash ( seq quot -- hash ) over length rot [ -rot [ >r call swap r> set-hash ] 2keep ] each nip ; inline diff --git a/library/collections/sequence-combinators.factor b/library/collections/sequence-combinators.factor index 50bf378756..27b55ed72a 100644 --- a/library/collections/sequence-combinators.factor +++ b/library/collections/sequence-combinators.factor @@ -4,7 +4,7 @@ IN: sequences-internals USING: arrays generic kernel kernel-internals math sequences vectors ; -: collect ( n quot -- array ) | quot ( n -- value ) +: collect ( n quot -- array ) >r [ f ] keep r> swap [ [ rot >r [ swap call ] keep r> set-array-nth ] 3keep ] repeat drop ; inline @@ -32,36 +32,36 @@ vectors ; IN: sequences -: each ( seq quot -- ) | quot ( elt -- ) +: each ( seq quot -- ) swap dup length [ [ swap nth-unsafe swap call ] 3keep ] repeat 2drop ; inline -: each-with ( obj seq quot -- ) | quot ( obj elt -- ) +: each-with ( obj seq quot -- ) swap [ with ] each 2drop ; inline -: reduce ( seq identity quot -- value ) | quot ( x y -- z ) +: reduce ( seq identity quot -- value ) swapd each ; inline -: map ( seq quot -- seq ) | quot ( elt -- elt ) +: map ( seq quot -- seq ) over >r over length [ (map) ] collect r> like 2nip ; inline -: map-with ( obj list quot -- list ) | quot ( obj elt -- elt ) +: map-with ( obj list quot -- list ) swap [ with rot ] map 2nip ; inline -: accumulate ( seq identity quot -- values ) | quot ( x y -- z ) +: accumulate ( seq identity quot -- values ) rot [ pick >r swap call r> ] map-with nip ; inline : change-nth ( i seq quot -- ) -rot [ nth swap call ] 2keep set-nth ; inline -: inject ( seq quot -- ) | quot ( elt -- elt ) +: inject ( seq quot -- ) over length [ [ -rot change-nth ] 3keep ] repeat 2drop ; inline -: inject-with ( obj seq quot -- ) | quot ( obj elt -- elt ) +: inject-with ( obj seq quot -- ) swap [ with rot ] inject 2drop ; inline : min-length ( seq seq -- n ) @@ -73,7 +73,7 @@ IN: sequences : 2each ( seq seq quot -- ) -rot 2dup min-length [ (2each) ] repeat 3drop ; inline -: 2reduce ( seq seq identity quot -- value ) | quot ( e x y -- z ) +: 2reduce ( seq seq identity quot -- value ) >r -rot r> 2each ; inline : 2map ( seq seq quot -- seq ) @@ -93,13 +93,13 @@ IN: sequences ] if ] if-bounds ; inline -: find-with* ( obj i seq quot -- i elt ) | quot ( elt -- ? ) +: find-with* ( obj i seq quot -- i elt ) -rot [ with rot ] find* 2swap 2drop ; inline -: find ( seq quot -- i elt ) | quot ( elt -- ? ) +: find ( seq quot -- i elt ) 0 -rot find* ; inline -: find-with ( obj seq quot -- i elt ) | quot ( elt -- ? ) +: find-with ( obj seq quot -- i elt ) swap [ with rot ] find 2swap 2drop ; inline : find-last* ( i seq quot -- i elt ) @@ -111,13 +111,13 @@ IN: sequences ] if ] if-bounds ; inline -: find-last-with* ( obj i seq quot -- i elt ) | quot ( elt -- ? ) +: find-last-with* ( obj i seq quot -- i elt ) -rot [ with rot ] find-last* 2swap 2drop ; inline : find-last ( seq quot -- i elt ) >r [ length 1- ] keep r> find-last* ; inline -: find-last-with ( obj seq quot -- i elt ) | quot ( elt -- ? ) +: find-last-with ( obj seq quot -- i elt ) swap [ with rot ] find-last 2swap 2drop ; inline : contains? ( seq quot -- ? ) @@ -129,20 +129,20 @@ IN: sequences : all? ( seq quot -- ? ) swap [ swap call not ] contains-with? not ; inline -: all-with? ( obj seq quot -- ? ) | quot ( elt -- ? ) +: all-with? ( obj seq quot -- ? ) swap [ with rot ] all? 2nip ; inline -: subset ( seq quot -- seq ) | quot ( elt -- ? ) +: subset ( seq quot -- seq ) over >r over length rot [ -rot [ >r over >r call [ r> r> push ] [ r> r> 2drop ] if ] 2keep ] each r> like nip ; inline -: subset-with ( obj seq quot -- seq ) | quot ( obj elt -- ? ) +: subset-with ( obj seq quot -- seq ) swap [ with rot ] subset 2nip ; inline -: monotonic? ( seq quot -- ? ) | quot ( elt elt -- ? ) +: monotonic? ( seq quot -- ? ) swap dup length 1- [ pick pick >r >r (monotonic) r> r> rot ] all? 2nip ; inline @@ -154,7 +154,7 @@ IN: sequences if ] 2each 2drop ; inline -: cache-nth ( i seq quot -- elt ) | quot ( i -- elt ) +: cache-nth ( i seq quot -- elt ) pick pick ?nth dup [ >r 3drop r> ] [ diff --git a/library/collections/sequence-sort.factor b/library/collections/sequence-sort.factor index c424fce2d2..7856fda4b3 100644 --- a/library/collections/sequence-sort.factor +++ b/library/collections/sequence-sort.factor @@ -81,19 +81,19 @@ C: sorter ( seq start end -- sorter ) IN: sequences -: nsort ( seq quot -- | quot: elt elt -- -1/0/1 ) +: nsort ( seq quot -- ) swap dup length 1 <= [ 2drop ] [ 0 over length 1- (nsort) ] if ; inline -: sort ( seq quot -- seq | quot: elt elt -- -1/0/1 ) +: sort ( seq quot -- seq ) swap [ swap nsort ] immutable ; inline : natural-sort ( seq -- seq ) [ <=> ] sort ; -: binsearch ( elt seq quot -- i | quot: elt elt -- -1/0/1 ) +: binsearch ( elt seq quot -- i ) swap dup empty? [ 3drop -1 ] [ flatten-slice (binsearch) ] if ; inline -: binsearch* ( elt seq quot -- elt | quot: elt elt -- -1/0/1 ) +: binsearch* ( elt seq quot -- elt ) over >r binsearch dup -1 = [ r> 2drop f ] [ r> nth ] if ; inline diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index d872cc93b7..a86c15305d 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -66,7 +66,7 @@ M: object like drop ; : >resizable ( seq -- seq ) [ thaw dup ] keep nappend ; -: immutable ( seq quot -- seq | quot: seq -- ) +: immutable ( seq quot -- seq ) swap [ >resizable [ swap call ] keep ] keep like ; inline : append ( s1 s2 -- s1+s2 ) diff --git a/library/collections/slicing.factor b/library/collections/slicing.factor index 10392aca48..1c3f5f5ab3 100644 --- a/library/collections/slicing.factor +++ b/library/collections/slicing.factor @@ -97,11 +97,11 @@ strings vectors ; : split-next, V{ } clone , ; -: (split) ( separator elt -- | separator: elt -- ? ) +: (split) ( separator elt -- ) [ swap call ] keep swap [ drop split-next, ] [ split, ] if ; inline -: split* ( seq separator -- split | separator: elt -- ? ) +: split* ( seq separator -- split ) over >r [ split-next, swap [ (split) ] each-with ] { } make r> swap [ swap like ] map-with ; inline diff --git a/library/compiler/alien/alien-invoke.factor b/library/compiler/alien/alien-invoke.factor index ba4664623b..b0da9cf211 100644 --- a/library/compiler/alien/alien-invoke.factor +++ b/library/compiler/alien/alien-invoke.factor @@ -70,16 +70,15 @@ M: alien-invoke generate-node M: alien-invoke stack-reserve* alien-invoke-parameters stack-space ; -: parse-arglist ( return seq -- types stack-effect ) +: parse-arglist ( return seq -- types effect ) 2 group unpair - rot dup "void" = [ drop { } ] [ 1array ] if 2array - effect>string ; + rot dup "void" = [ drop { } ] [ 1array ] if ; : (define-c-word) ( type lib func types stack-effect -- ) >r over create-in dup reset-generic >r [ alien-invoke ] curry curry curry curry r> swap define-compound word r> - "stack-effect" set-word-prop ; + "declared-effect" set-word-prop ; : define-c-word ( return library function parameters -- ) [ "()" subseq? not ] subset >r pick r> parse-arglist diff --git a/library/compiler/alien/compiler.factor b/library/compiler/alien/compiler.factor index 5d001e831f..9f235e5ebf 100644 --- a/library/compiler/alien/compiler.factor +++ b/library/compiler/alien/compiler.factor @@ -61,7 +61,7 @@ kernel-internals math namespaces sequences words ; : box-parameter ( stack# type -- node ) c-type [ "reg-class" get "boxer" get call ] bind ; -: if-void ( type true false -- | false: type -- ) +: if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline : compile-gc ; ! "simple_gc" f %alien-invoke , ; diff --git a/library/compiler/alien/malloc.factor b/library/compiler/alien/malloc.factor index 0afca8c89d..3212b55820 100644 --- a/library/compiler/alien/malloc.factor +++ b/library/compiler/alien/malloc.factor @@ -13,5 +13,5 @@ FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ; TUPLE: check-ptr ; : check-ptr [ throw ] unless* ; -: with-malloc ( size quot -- | quot: alien -- ) +: with-malloc ( size quot -- ) swap 1 calloc check-ptr [ swap call ] keep free ; inline diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor index 74fdad764a..b4bb599532 100644 --- a/library/compiler/generator/generator.factor +++ b/library/compiler/generator/generator.factor @@ -36,7 +36,7 @@ UNION: #terminal dup #terminal-call? swap node-successor #terminal? or ] all? ; -: generate-code ( node quot -- | quot: node -- ) +: generate-code ( node quot -- ) over stack-reserve %prologue call ; inline : init-generator ( -- ) @@ -44,7 +44,7 @@ UNION: #terminal V{ } clone literal-table set V{ } clone label-table set ; -: generate-1 ( word node quot -- ) | quot ( node -- ) +: generate-1 ( word node quot -- ) #! Generate the code, then dump three vectors to pass to #! add-compiled-block. pick f save-xt [ @@ -99,10 +99,10 @@ M: #if generate-node : [with-template] ( quot template -- quot ) 2array >quotation [ with-template ] append ; -: define-intrinsic ( word quot template -- ) | quot ( -- ) +: define-intrinsic ( word quot template -- ) [with-template] "intrinsic" set-word-prop ; -: define-if-intrinsic ( word quot template -- ) | quot ( label -- ) +: define-if-intrinsic ( word quot template -- ) [with-template] "if-intrinsic" set-word-prop ; : if>boolean-intrinsic ( label -- ) diff --git a/library/compiler/inference/dataflow.factor b/library/compiler/inference/dataflow.factor index 322161a7e1..53eb6a3623 100644 --- a/library/compiler/inference/dataflow.factor +++ b/library/compiler/inference/dataflow.factor @@ -144,7 +144,7 @@ SYMBOL: current-node : #drop ( n -- #shuffle ) d-tail in-node <#shuffle> ; -: each-node ( node quot -- ) | quot ( node -- ) +: each-node ( node quot -- ) over [ [ call ] 2keep swap [ node-children [ swap each-node ] each-with ] 2keep @@ -153,10 +153,10 @@ SYMBOL: current-node 2drop ] if ; inline -: each-node-with ( obj node quot -- ) | quot ( obj node -- ) +: each-node-with ( obj node quot -- ) swap [ with ] each-node 2drop ; inline -: all-nodes? ( node quot -- ? ) | quot ( node -- ? ) +: all-nodes? ( node quot -- ? ) over [ [ call ] 2keep rot [ [ @@ -173,7 +173,7 @@ SYMBOL: current-node 2drop t ] if ; inline -: all-nodes-with? ( obj node quot -- ? ) | quot ( obj node -- ? ) +: all-nodes-with? ( obj node quot -- ? ) swap [ with rot ] all-nodes? 2nip ; inline : remember-node ( word node -- ) @@ -237,20 +237,20 @@ DEFER: (map-nodes) drop ] if* ; inline -: (map-nodes) ( prev quot -- ) | quot ( node -- node ) +: (map-nodes) ( prev quot -- ) node@ [ [ map-node ] keep map-next ] [ drop f swap ?set-node-successor ] if ; inline -: map-first ( node quot -- node ) | quot ( node -- node ) +: map-first ( node quot -- node ) call node> drop dup >node ; inline -: map-nodes ( node quot -- node ) | quot ( node -- node ) +: map-nodes ( node quot -- node ) over [ over >node [ map-first ] keep map-next node> ] when drop ; inline -: map-children ( quot -- ) | quot ( node -- node ) +: map-children ( quot -- ) node@ [ node-children [ swap map-nodes ] map-with ] keep set-node-children ; inline diff --git a/library/compiler/optimizer/kill-literals.factor b/library/compiler/optimizer/kill-literals.factor index 270d64704a..6cf9573335 100644 --- a/library/compiler/optimizer/kill-literals.factor +++ b/library/compiler/optimizer/kill-literals.factor @@ -4,7 +4,7 @@ IN: optimizer USING: arrays generic hashtables inference kernel math namespaces sequences words ; -: node-union ( node quot -- hash | quot: node -- ) +: node-union ( node quot -- hash ) [ swap [ swap call [ dup set ] each ] each-node-with ] make-hash ; inline diff --git a/library/continuations.factor b/library/continuations.factor index d0602d4847..5ff94bcaef 100644 --- a/library/continuations.factor +++ b/library/continuations.factor @@ -33,7 +33,7 @@ TUPLE: continuation data retain call name catch ; [ continuation-name ] keep continuation-catch ; inline -: ifcc ( terminator balance -- | quot: continuation -- ) +: ifcc ( terminator balance -- ) [ f f continuation 2nip dup ] call 2swap if ; inline : callcc0 [ drop ] ifcc ; inline diff --git a/library/effects.factor b/library/effects.factor new file mode 100644 index 0000000000..436b8c79b0 --- /dev/null +++ b/library/effects.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: words +USING: kernel math namespaces sequences strings generic ; + +TUPLE: effect in out terminated? ; + +C: effect + [ + over { "*" } sequence= + [ nip t swap set-effect-terminated? ] + [ set-effect-out ] if + ] keep + [ set-effect-in ] keep ; + +: effect-height ( effect -- n ) + dup effect-out length swap effect-in length - ; + +: effect<= ( eff1 eff2 -- ? ) + 2dup [ effect-terminated? ] 2apply = >r + 2dup [ effect-in length ] 2apply <= >r + [ effect-height ] 2apply number= r> and r> and ; + +: stack-picture ( seq -- string ) + [ + [ + { + { [ dup string? ] [ ] } + { [ dup word? ] [ word-name ] } + { [ dup integer? ] [ drop "object" ] } + } cond % CHAR: \s , + ] each + ] "" make ; + +: effect>string ( effect -- string ) + [ + "( " % + dup effect-in stack-picture % + "-- " % + dup effect-out stack-picture % + effect-terminated? [ "* " % ] when + ")" % + ] "" make ; + +: stack-effect ( word -- string ) + dup "declared-effect" word-prop [ + effect>string + ] [ + dup "infer-effect" word-prop [ + effect>string + ] [ + drop f + ] ?if + ] ?if ; diff --git a/library/errors.factor b/library/errors.factor index e3beb69f6d..e0a9b79c88 100644 --- a/library/errors.factor +++ b/library/errors.factor @@ -12,7 +12,7 @@ USING: kernel ; SYMBOL: error SYMBOL: error-continuation -: catch ( try -- error | try: -- ) +: catch ( try -- error ) [ >c call f c> drop f ] callcc1 nip ; inline : rethrow ( error -- ) @@ -23,12 +23,12 @@ SYMBOL: error-continuation c> dup quotation? [ call ] [ continue-with ] if ] if ; -: cleanup ( try cleanup -- | try: -- | cleanup: -- ) +: cleanup ( try cleanup -- ) [ >c >r call c> drop r> call ] [ drop (continue-with) >r nip call r> rethrow ] ifcc ; inline -: recover ( try recovery -- | try: -- | recovery: error -- ) +: recover ( try recovery -- ) [ >c drop call c> drop ] [ drop (continue-with) rot drop swap call ] ifcc ; inline diff --git a/library/generic/classes.factor b/library/generic/classes.factor index 72414706f7..673589b1b6 100644 --- a/library/generic/classes.factor +++ b/library/generic/classes.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: generic USING: arrays definitions errors hashtables kernel -kernel-internals namespaces parser sequences strings words +kernel-internals namespaces sequences strings words vectors math parser ; PREDICATE: word class "class" word-prop ; diff --git a/library/generic/methods.factor b/library/generic/methods.factor index 23f8e17ef8..5ceed8253b 100644 --- a/library/generic/methods.factor +++ b/library/generic/methods.factor @@ -35,7 +35,7 @@ TUPLE: check-method class generic ; dup generic? [ throw ] unless over class? [ throw ] unless ; -: with-methods ( word quot -- | quot: methods -- ) +: with-methods ( word quot -- ) swap [ "methods" word-prop swap call ] keep ?make-generic ; inline diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 9608494d61..baf86c1cef 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -91,7 +91,7 @@ M: tuple equal? : delegates ( obj -- seq ) [ (delegates) ] { } make ; -: is? ( obj pred -- ? | pred: obj -- ? ) +: is? ( obj pred -- ? ) >r delegates r> contains? ; inline : >tuple ( seq -- tuple ) diff --git a/library/help/help.factor b/library/help/help.factor index b67503d3f1..fce0304f32 100644 --- a/library/help/help.factor +++ b/library/help/help.factor @@ -51,7 +51,7 @@ M: word article-content subsection-style [ first ($subsection) ] with-style ] ($block) ; -: help-outliner ( seq -- | quot: obj -- ) +: help-outliner ( seq -- ) subsection-style [ sort-articles [ ($subsection) terpri ] each ] with-style ; diff --git a/library/help/topics.factor b/library/help/topics.factor index 0de1318385..2d4aa5e0f9 100644 --- a/library/help/topics.factor +++ b/library/help/topics.factor @@ -95,7 +95,7 @@ M: word-link where link-name "help-loc" word-prop ; M: word-link (synopsis) \ HELP: pprint-word link-name dup pprint-word - "stack-effect" word-prop pprint* ; + stack-effect comment. ; M: word-link definition link-name "help" word-prop t ; diff --git a/library/io/string-streams.factor b/library/io/string-streams.factor index 37358d0d3c..8db8ab3166 100644 --- a/library/io/string-streams.factor +++ b/library/io/string-streams.factor @@ -22,7 +22,7 @@ M: sbuf stream-flush drop ; [ swap CHAR: \s pad-right ] map-with ] unless ; -: map-last ( seq quot -- seq | quot: elt last? ) +: map-last ( seq quot -- seq ) swap dup length [ zero? rot [ call ] keep swap ] 2map nip ; inline diff --git a/library/io/unix/sockets.factor b/library/io/unix/sockets.factor index 161d3e0d89..a35889cd36 100644 --- a/library/io/unix/sockets.factor +++ b/library/io/unix/sockets.factor @@ -24,7 +24,7 @@ threads unix-internals ; : socket-fd ( -- socket ) PF_INET SOCK_STREAM 0 socket dup io-error dup init-handle ; -: with-socket-fd ( quot -- fd | quot: socket -- n ) +: with-socket-fd ( quot -- fd ) socket-fd [ swap call ] keep swap 0 < [ err_no EINPROGRESS = [ dup close (io-error) ] unless ] when ; inline diff --git a/library/math/math.factor b/library/math/math.factor index 0e1ec31c89..72b5512afb 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -64,7 +64,7 @@ M: object zero? drop f ; : repeat 0 -rot (repeat) ; inline -: times ( n quot -- ) | quot ( -- ) +: times ( n quot -- ) swap [ >r dup slip r> ] repeat drop ; inline GENERIC: number>string ( n -- str ) foldable diff --git a/library/syntax/early-parser.factor b/library/syntax/early-parser.factor index 4a89828fb9..2f3ccd1294 100644 --- a/library/syntax/early-parser.factor +++ b/library/syntax/early-parser.factor @@ -50,22 +50,3 @@ C: parse-error ( error -- error ) column get over set-parse-error-col line-text get over set-parse-error-text [ set-delegate ] keep ; - -TUPLE: effect in out declarations terminated? ; - -C: effect - [ - over { "*" } sequence= - [ nip t swap set-effect-terminated? ] - [ set-effect-out ] if - ] keep - [ set-effect-in ] keep - H{ } clone over set-effect-declarations ; - -: effect-height ( effect -- n ) - dup effect-out length swap effect-in length - ; - -: effect<= ( eff1 eff2 -- ? ) - 2dup [ effect-terminated? ] 2apply = >r - 2dup [ effect-in length ] 2apply <= >r - [ effect-height ] 2apply number= r> and r> and ; diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index e9d0be7384..f8986449a0 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -79,13 +79,4 @@ DEFER: !PRIMITIVE: parsing [ string-mode off [ (require) ] each ] f ; parsing : !( - word parse-effect dup 1array >vector effect-stack set - "declared-effect" set-word-prop ; parsing - -: !| - scan scan-word \ ( eq? [ - parse-effect dup effect-stack get push - swap add-declaration - ] [ - "Expected (" throw - ] if ; parsing + word parse-effect "declared-effect" set-word-prop ; parsing diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index c3a49677b7..307fddfa30 100644 --- a/library/syntax/parser.factor +++ b/library/syntax/parser.factor @@ -4,7 +4,7 @@ IN: parser USING: arrays definitions errors generic hashtables kernel math namespaces prettyprint sequences strings vectors words ; -: skip ( i seq quot -- n | quot: elt -- ? ) +: skip ( i seq quot -- n ) over >r find* drop dup -1 = [ drop r> length ] [ r> drop ] if ; inline @@ -90,8 +90,6 @@ TUPLE: bad-escape ; column [ [ line-text get (parse-string) ] "" make swap ] change ; -SYMBOL: effect-stack - : (parse-effect) ( -- ) scan [ dup ")" = [ drop ] [ , (parse-effect) ] if @@ -103,11 +101,6 @@ SYMBOL: effect-stack [ (parse-effect) column get ] { } make swap column set { "--" } split1 ; -: add-declaration ( effect name -- ) - effect-stack get [ - 2dup effect-in member? >r dupd effect-out member? r> or - ] find nip effect-declarations set-hash ; - global [ { "scratchpad" "syntax" "arrays" "compiler" "definitions" diff --git a/library/test/parser.factor b/library/test/parser.factor index eeb1cc26c7..ee606814b9 100644 --- a/library/test/parser.factor +++ b/library/test/parser.factor @@ -60,21 +60,9 @@ unit-test : foo ( a b -- c ) + ; -[ T{ effect f { "a" "b" } { "c" } H{ } f } ] +[ T{ effect f { "a" "b" } { "c" } f } ] [ \ foo "declared-effect" word-prop ] unit-test -: bar ( a quot -- b ) | quot ( u -- v ) call ; - -[ - T{ effect f - { "a" "quot" } - { "b" } - H{ { "quot" T{ effect f { "u" } { "v" } H{ } } } } - f - } -] -[ \ bar "declared-effect" word-prop ] unit-test - [ t ] [ 1 1 2 2 effect<= ] unit-test [ f ] [ 1 0 2 2 effect<= ] unit-test [ t ] [ 2 2 2 2 effect<= ] unit-test diff --git a/library/test/prettyprint.factor b/library/test/prettyprint.factor index b27efc9c88..612189501a 100644 --- a/library/test/prettyprint.factor +++ b/library/test/prettyprint.factor @@ -39,7 +39,8 @@ unit-test : bar ( x -- y ) 2 + ; -[ "IN: temporary : bar 2 + ;\n" ] [ [ \ bar see ] string-out ] unit-test +[ "IN: temporary : bar ( x -- y ) 2 + ;\n" ] +[ [ \ bar see ] string-out ] unit-test [ "( a b -- c d )" ] [ { { "a" "b" } { "c" "d" } } effect>string diff --git a/library/tools/definitions.factor b/library/tools/definitions.factor index ec4a2e69e4..b5d699550b 100644 --- a/library/tools/definitions.factor +++ b/library/tools/definitions.factor @@ -20,21 +20,20 @@ GENERIC: (synopsis) ( spec -- ) H{ } r >r dup word-def r> call r> swap define-compound ; inline diff --git a/library/ui/cocoa/callback.factor b/library/ui/cocoa/callback.factor index eaf14e8d66..9f7c2ee628 100644 --- a/library/ui/cocoa/callback.factor +++ b/library/ui/cocoa/callback.factor @@ -27,6 +27,6 @@ reset-callbacks } } { } define-objc-class -: ( quot -- id | quot: id -- ) +: ( quot -- id ) FactorCallback -> alloc -> init [ callbacks get set-hash ] keep ; \ No newline at end of file diff --git a/library/ui/cocoa/services.factor b/library/ui/cocoa/services.factor index 6f929bc809..7e65c8659b 100644 --- a/library/ui/cocoa/services.factor +++ b/library/ui/cocoa/services.factor @@ -18,7 +18,7 @@ parser prettyprint styles ; nip pasteboard-error ] if ; -: do-service ( pboard error quot -- | quot: str -- str/f ) +: do-service ( pboard error quot -- ) pick >r >r ?pasteboard-string dup [ r> call ] [ r> 2drop f ] if dup [ r> set-pasteboard-string ] [ r> 2drop ] if ; diff --git a/library/ui/gadgets/grids.factor b/library/ui/gadgets/grids.factor index 25d806800b..e08b1225b7 100644 --- a/library/ui/gadgets/grids.factor +++ b/library/ui/gadgets/grids.factor @@ -31,7 +31,7 @@ C: grid ( children -- grid ) pref-dim-grid dup flip [ max-dim ] map swap [ max-dim ] map ; -: with-grid ( grid quot -- | quot: horiz vert -- ) +: with-grid ( grid quot -- ) [ >r grid set compute-grid r> call ] with-scope ; inline : gap grid get grid-gap ; diff --git a/library/ui/gadgets/paragraphs.factor b/library/ui/gadgets/paragraphs.factor index 249879994d..c854833b6f 100644 --- a/library/ui/gadgets/paragraphs.factor +++ b/library/ui/gadgets/paragraphs.factor @@ -42,7 +42,7 @@ SYMBOL: margin dup line-height [ max ] change y get + max-y [ max ] change ; -: wrap-step ( quot child -- | quot: pos child -- ) +: wrap-step ( quot child -- ) dup pref-dim [ over word-break-gadget? [ dup first overrun? [ wrap-line ] when @@ -55,7 +55,7 @@ SYMBOL: margin paragraph-margin margin set 0 { x max-x y max-y line-height } [ set ] each-with ; -: do-wrap ( paragraph quot -- dim | quot: pos child -- ) +: do-wrap ( paragraph quot -- dim ) [ swap dup init-wrap [ wrap-step ] each-child-with wrap-dim diff --git a/library/ui/gadgets/tiles.factor b/library/ui/gadgets/tiles.factor index 0875cbd034..c9716a2572 100644 --- a/library/ui/gadgets/tiles.factor +++ b/library/ui/gadgets/tiles.factor @@ -8,7 +8,7 @@ TUPLE: tile gadget ; : find-tile [ tile? ] find-parent ; -: ( quot -- gadget | quot: tile -- ) +: ( quot -- gadget ) { 0.0 0.0 0.0 1.0 } close-box [ find-tile ] rot append ; @@ -18,7 +18,7 @@ TUPLE: tile gadget ; { [