Fix M: stack effects.

db4
John Benediktsson 2011-10-13 16:19:03 -07:00
parent ba7a005e88
commit 1987deb359
16 changed files with 21 additions and 21 deletions

View File

@ -138,7 +138,7 @@ M: vreg-insn compute-live-intervals* ( insn -- )
GENERIC: uses-vregs* ( insn -- seq ) 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 ; [ uses-vregs ] [ gc-map>> derived-roots>> values ] bi append ;
M: vreg-insn uses-vregs* uses-vregs ; M: vreg-insn uses-vregs* uses-vregs ;

View File

@ -77,5 +77,5 @@ FORWARD-ANALYSIS: uninitialized
M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' ) M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
drop [ prepare ] dip visit-block finish ; 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 ; 2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;

View File

@ -13,7 +13,7 @@ TUPLE: db-pool < pool db ;
: with-db-pool ( db quot -- ) : with-db-pool ( db quot -- )
[ <db-pool> ] dip with-pool ; inline [ <db-pool> ] dip with-pool ; inline
M: db-pool make-connection ( pool -- ) M: db-pool make-connection ( pool -- conn )
db>> db-open ; db>> db-open ;
: with-pooled-db ( pool quot -- ) : with-pooled-db ( pool quot -- )

View File

@ -85,7 +85,7 @@ M: dlist push-back* ( obj dlist -- dlist-node )
ERROR: empty-dlist ; ERROR: empty-dlist ;
M: empty-dlist summary ( dlist -- ) M: empty-dlist summary ( dlist -- string )
drop "Empty dlist" ; drop "Empty dlist" ;
M: dlist peek-front ( dlist -- obj ) M: dlist peek-front ( dlist -- obj )

View File

@ -88,7 +88,7 @@ ERROR: end-aside-in-get-error ;
: end-aside ( default -- response ) : end-aside ( default -- response )
aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ; aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
M: asides link-attr ( tag -- ) M: asides link-attr ( tag responder -- )
drop drop
"aside" optional-attr { "aside" optional-attr {
{ "none" [ aside-id off ] } { "none" [ aside-id off ] }
@ -103,7 +103,7 @@ M: asides modify-query ( query asides -- query' )
aside-id-key associate assoc-union aside-id-key associate assoc-union
] when* ; ] when* ;
M: asides modify-form ( asides -- ) M: asides modify-form ( asides -- xml/f )
drop drop
aside-id get aside-id get
aside-id-key aside-id-key

View File

@ -30,7 +30,7 @@ M: login-realm init-realm
M: login-realm logged-in-username M: login-realm logged-in-username
drop permit-id get dup [ get-permit-uid ] when ; 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 ; drop permit-id get realm get name>> permit-id-key hidden-form-field ;
: <permit-cookie> ( -- cookie ) : <permit-cookie> ( -- cookie )
@ -107,7 +107,7 @@ M: login-realm login-required* ( description capabilities login -- response )
URL" $realm/login" <continue-conversation> URL" $realm/login" <continue-conversation>
] if ; ] if ;
M: login-realm user-registered ( user realm -- ) M: login-realm user-registered ( user realm -- response )
drop successful-login ; drop successful-login ;
: <login-realm> ( responder name -- realm ) : <login-realm> ( responder name -- realm )

View File

@ -107,7 +107,7 @@ M: conversations call-responder*
bi bi
] [ 2drop ] if ; ] [ 2drop ] if ;
M: conversations modify-form ( conversations -- ) M: conversations modify-form ( conversations -- xml/f )
drop drop
conversation-id get conversation-id get
conversation-id-key conversation-id-key

View File

@ -98,7 +98,7 @@ CONSTANT: session-id-key "__s"
: put-session-cookie ( response -- response' ) : put-session-cookie ( response -- response' )
<session-cookie> put-cookie ; <session-cookie> put-cookie ;
M: sessions modify-form ( responder -- ) M: sessions modify-form ( responder -- xml/f )
drop session get id>> session-id-key hidden-form-field ; drop session get id>> session-id-key hidden-form-field ;
M: sessions call-responder* ( path responder -- response ) M: sessions call-responder* ( path responder -- response )

View File

@ -124,7 +124,7 @@ CONSTANT: pre-css "white-space: pre; font-family: monospace;"
TUPLE: html-block-stream < html-sub-stream ; 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 ; end-sub-stream format-html-div ;
: border-spacing-css, ( pair -- ) : border-spacing-css, ( pair -- )

View File

@ -17,7 +17,7 @@ name-max flags id ;
HOOK: new-file-system-info os ( -- file-system-info ) 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 ) HOOK: file-system-statfs os ( path -- statfs )

View File

@ -476,7 +476,7 @@ M: ebnf-sequence build-locals ( code ast -- code )
] if ] if
] 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 " % "FROM: locals => [let :> ; FROM: kernel => dup nip ; [let " %
" dup :> " % name>> % " dup :> " % name>> %
@ -485,9 +485,9 @@ M: ebnf-var build-locals ( code ast -- )
" nip ]" % " nip ]" %
] "" make ; ] "" make ;
M: object build-locals ( code ast -- ) M: object build-locals ( code ast -- code )
drop ; drop ;
ERROR: bad-effect quot effect ; ERROR: bad-effect quot effect ;
: check-action-effect ( quot -- quot ) : check-action-effect ( quot -- quot )

View File

@ -110,7 +110,7 @@ SYMBOL: thread-error-hook ! ( error thread -- )
thread-error-hook [ [ die ] ] initialize 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 -- * ) ; thread-error-hook get-global call( error thread -- * ) ;
: in-callback? ( -- ? ) 3 context-object ; : in-callback? ( -- ? ) 3 context-object ;

View File

@ -26,5 +26,5 @@ M: assoc-heap heap-pop ( assoc-heap -- value key )
M: assoc-heap heap-peek ( assoc-heap -- value key ) M: assoc-heap heap-peek ( assoc-heap -- value key )
heap>> heap-peek ; heap>> heap-peek ;
M: assoc-heap heap-empty? ( assoc-heap -- value key ) M: assoc-heap heap-empty? ( assoc-heap -- ? )
heap>> heap-empty? ; heap>> heap-empty? ;

View File

@ -15,7 +15,7 @@ PREDICATE: change-tracking-tuple-class < tuple-class
<PRIVATE <PRIVATE
M: change-tracking-tuple-class writer-quot ( class slot-spec -- ) M: change-tracking-tuple-class writer-quot ( class slot-spec -- quot )
[ call-next-method ] [ call-next-method ]
[ name>> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ; [ name>> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ;

View File

@ -32,7 +32,7 @@ C: <scaled> scaled
M: scaled modified-nth ( n seq -- elt ) M: scaled modified-nth ( n seq -- elt )
[ seq>> nth ] [ c>> * ] bi ; [ 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! ! don't set c to 0!
elt seq c>> / n seq seq>> set-nth ; elt seq c>> / n seq seq>> set-nth ;
@ -63,7 +63,7 @@ M: summed length seqs>> [ length ] [ max ] map-reduce ;
] if* ; ] if* ;
PRIVATE> PRIVATE>
M: summed modified-nth ( n seq -- ) M: summed modified-nth ( n seq -- elt )
seqs>> [ ?nth ?+ ] with 0 swap reduce ; seqs>> [ ?nth ?+ ] with 0 swap reduce ;
M: summed modified-set-nth ( elt n seq -- ) immutable ; M: summed modified-set-nth ( elt n seq -- ) immutable ;

View File

@ -80,7 +80,7 @@ DEFER: avl-set
: avl-set ( value key node -- node taller? ) : avl-set ( value key node -- node taller? )
[ (avl-set) ] [ swap <avl-node> t ] if* ; [ (avl-set) ] [ swap <avl-node> t ] if* ;
M: avl set-at ( value key node -- node ) M: avl set-at ( value key node -- )
[ avl-set drop ] change-root drop ; [ avl-set drop ] change-root drop ;
: delete-select-rotate ( node -- node shorter? ) : delete-select-rotate ( node -- node shorter? )