Fix M: stack effects.
parent
ba7a005e88
commit
1987deb359
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
||||||
|
|
|
@ -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,7 +485,7 @@ 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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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? ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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? )
|
||||||
|
|
Loading…
Reference in New Issue