From: John Benediktsson Date: Thu, 13 Oct 2011 23:19:03 +0000 (-0700) Subject: Fix M: stack effects. X-Git-Tag: 0.97~3940 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=1987deb35982597d934edb1fae821250b356d39b Fix M: stack effects. --- diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 37707e294e..a514a6738e 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -138,7 +138,7 @@ M: vreg-insn compute-live-intervals* ( insn -- ) GENERIC: uses-vregs* ( insn -- seq ) -M: gc-map-insn uses-vregs* ( insn -- ) +M: gc-map-insn uses-vregs* [ uses-vregs ] [ gc-map>> derived-roots>> values ] bi append ; M: vreg-insn uses-vregs* uses-vregs ; diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor index 7498cddf10..7ceb867dbc 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -77,5 +77,5 @@ FORWARD-ANALYSIS: uninitialized M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' ) drop [ prepare ] dip visit-block finish ; -M: uninitialized-analysis join-sets ( sets analysis -- pair ) +M: uninitialized-analysis join-sets ( sets bb dfa -- set ) 2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ; diff --git a/basis/db/pools/pools.factor b/basis/db/pools/pools.factor index 55ff3a383b..b0d9d69913 100644 --- a/basis/db/pools/pools.factor +++ b/basis/db/pools/pools.factor @@ -13,7 +13,7 @@ TUPLE: db-pool < pool db ; : with-db-pool ( db quot -- ) [ ] dip with-pool ; inline -M: db-pool make-connection ( pool -- ) +M: db-pool make-connection ( pool -- conn ) db>> db-open ; : with-pooled-db ( pool quot -- ) diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index c4b191360b..27c3025dc7 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -85,7 +85,7 @@ M: dlist push-back* ( obj dlist -- dlist-node ) ERROR: empty-dlist ; -M: empty-dlist summary ( dlist -- ) +M: empty-dlist summary ( dlist -- string ) drop "Empty dlist" ; M: dlist peek-front ( dlist -- obj ) diff --git a/basis/furnace/asides/asides.factor b/basis/furnace/asides/asides.factor index 8700946bb5..254cb04fed 100644 --- a/basis/furnace/asides/asides.factor +++ b/basis/furnace/asides/asides.factor @@ -88,7 +88,7 @@ ERROR: end-aside-in-get-error ; : end-aside ( default -- response ) aside-id get aside-id off get-aside [ move-on ] [ ] ?if ; -M: asides link-attr ( tag -- ) +M: asides link-attr ( tag responder -- ) drop "aside" optional-attr { { "none" [ aside-id off ] } @@ -103,7 +103,7 @@ M: asides modify-query ( query asides -- query' ) aside-id-key associate assoc-union ] when* ; -M: asides modify-form ( asides -- ) +M: asides modify-form ( asides -- xml/f ) drop aside-id get aside-id-key diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor index 9c3d316d03..74ff38141c 100644 --- a/basis/furnace/auth/login/login.factor +++ b/basis/furnace/auth/login/login.factor @@ -30,7 +30,7 @@ M: login-realm init-realm M: login-realm logged-in-username drop permit-id get dup [ get-permit-uid ] when ; -M: login-realm modify-form ( responder -- ) +M: login-realm modify-form ( responder -- xml/f ) drop permit-id get realm get name>> permit-id-key hidden-form-field ; : ( -- cookie ) @@ -107,7 +107,7 @@ M: login-realm login-required* ( description capabilities login -- response ) URL" $realm/login" ] if ; -M: login-realm user-registered ( user realm -- ) +M: login-realm user-registered ( user realm -- response ) drop successful-login ; : ( responder name -- realm ) diff --git a/basis/furnace/conversations/conversations.factor b/basis/furnace/conversations/conversations.factor index bbb84e2f05..82a4de2429 100644 --- a/basis/furnace/conversations/conversations.factor +++ b/basis/furnace/conversations/conversations.factor @@ -107,7 +107,7 @@ M: conversations call-responder* bi ] [ 2drop ] if ; -M: conversations modify-form ( conversations -- ) +M: conversations modify-form ( conversations -- xml/f ) drop conversation-id get conversation-id-key diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor index 33de393d90..13deeff9a0 100644 --- a/basis/furnace/sessions/sessions.factor +++ b/basis/furnace/sessions/sessions.factor @@ -98,7 +98,7 @@ CONSTANT: session-id-key "__s" : put-session-cookie ( response -- response' ) put-cookie ; -M: sessions modify-form ( responder -- ) +M: sessions modify-form ( responder -- xml/f ) drop session get id>> session-id-key hidden-form-field ; M: sessions call-responder* ( path responder -- response ) diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index fbce1e81d7..b865206219 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -124,7 +124,7 @@ CONSTANT: pre-css "white-space: pre; font-family: monospace;" TUPLE: html-block-stream < html-sub-stream ; -M: html-block-stream dispose ( quot style stream -- ) +M: html-block-stream dispose end-sub-stream format-html-div ; : border-spacing-css, ( pair -- ) diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 6df4f40739..554c6f006b 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -17,7 +17,7 @@ name-max flags id ; HOOK: new-file-system-info os ( -- file-system-info ) -M: unix new-file-system-info ( -- ) unix-file-system-info new ; +M: unix new-file-system-info unix-file-system-info new ; HOOK: file-system-statfs os ( path -- statfs ) diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index d808b9aaa0..7f4f52e2e4 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -476,7 +476,7 @@ M: ebnf-sequence build-locals ( code ast -- code ) ] if ] if ; -M: ebnf-var build-locals ( code ast -- ) +M: ebnf-var build-locals ( code ast -- code ) [ "FROM: locals => [let :> ; FROM: kernel => dup nip ; [let " % " dup :> " % name>> % @@ -485,9 +485,9 @@ M: ebnf-var build-locals ( code ast -- ) " nip ]" % ] "" make ; -M: object build-locals ( code ast -- ) +M: object build-locals ( code ast -- code ) drop ; - + ERROR: bad-effect quot effect ; : check-action-effect ( quot -- quot ) diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index ec8be7efa4..bfcca41587 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -110,7 +110,7 @@ SYMBOL: thread-error-hook ! ( error thread -- ) thread-error-hook [ [ die ] ] initialize -M: object error-in-thread ( error thread -- ) +M: object error-in-thread ( error thread -- * ) thread-error-hook get-global call( error thread -- * ) ; : in-callback? ( -- ? ) 3 context-object ; diff --git a/extra/assoc-heaps/assoc-heaps.factor b/extra/assoc-heaps/assoc-heaps.factor index a495aed626..160c3d3111 100644 --- a/extra/assoc-heaps/assoc-heaps.factor +++ b/extra/assoc-heaps/assoc-heaps.factor @@ -26,5 +26,5 @@ M: assoc-heap heap-pop ( assoc-heap -- value key ) M: assoc-heap heap-peek ( assoc-heap -- value key ) heap>> heap-peek ; -M: assoc-heap heap-empty? ( assoc-heap -- value key ) +M: assoc-heap heap-empty? ( assoc-heap -- ? ) heap>> heap-empty? ; diff --git a/extra/classes/tuple/change-tracking/change-tracking.factor b/extra/classes/tuple/change-tracking/change-tracking.factor index 3e210922b5..0d5e41076d 100644 --- a/extra/classes/tuple/change-tracking/change-tracking.factor +++ b/extra/classes/tuple/change-tracking/change-tracking.factor @@ -15,7 +15,7 @@ PREDICATE: change-tracking-tuple-class < tuple-class > "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ; diff --git a/extra/sequences/modified/modified.factor b/extra/sequences/modified/modified.factor index 944242bac8..9205b91c4a 100644 --- a/extra/sequences/modified/modified.factor +++ b/extra/sequences/modified/modified.factor @@ -32,7 +32,7 @@ C: scaled M: scaled modified-nth ( n seq -- elt ) [ seq>> nth ] [ c>> * ] bi ; -M:: scaled modified-set-nth ( elt n seq -- elt ) +M:: scaled modified-set-nth ( elt n seq -- ) ! don't set c to 0! elt seq c>> / n seq seq>> set-nth ; @@ -63,7 +63,7 @@ M: summed length seqs>> [ length ] [ max ] map-reduce ; ] if* ; PRIVATE> -M: summed modified-nth ( n seq -- ) +M: summed modified-nth ( n seq -- elt ) seqs>> [ ?nth ?+ ] with 0 swap reduce ; M: summed modified-set-nth ( elt n seq -- ) immutable ; diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 69252bf762..c53d75de4c 100644 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -80,7 +80,7 @@ DEFER: avl-set : avl-set ( value key node -- node taller? ) [ (avl-set) ] [ swap t ] if* ; -M: avl set-at ( value key node -- node ) +M: avl set-at ( value key node -- ) [ avl-set drop ] change-root drop ; : delete-select-rotate ( node -- node shorter? )