use ``if*`` instead of ``dup [ ] [ drop ] if``.
parent
bbde85f56b
commit
5eec781b40
|
@ -34,7 +34,7 @@ TUPLE: from-message id ;
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
{ T{ to-message f ?id ?value }
|
{ T{ to-message f ?id ?value }
|
||||||
[ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
|
[ ?value ?id get-channel [ to f ] [ drop no-channel ] if* ] }
|
||||||
{ T{ from-message f ?id }
|
{ T{ from-message f ?id }
|
||||||
[ ?id get-channel [ from ] [ no-channel ] if* ] }
|
[ ?id get-channel [ from ] [ no-channel ] if* ] }
|
||||||
} match-cond
|
} match-cond
|
||||||
|
|
|
@ -33,7 +33,7 @@ GENERIC: visit-insn ( insn -- )
|
||||||
|
|
||||||
M: ##copy visit-insn
|
M: ##copy visit-insn
|
||||||
[ dst>> ] [ src>> resolve ] bi
|
[ dst>> ] [ src>> resolve ] bi
|
||||||
dup [ record-copy ] [ 2drop ] if ;
|
[ record-copy ] [ drop ] if* ;
|
||||||
|
|
||||||
: useless-phi ( dst inputs -- ) first record-copy ;
|
: useless-phi ( dst inputs -- ) first record-copy ;
|
||||||
|
|
||||||
|
|
|
@ -12,7 +12,7 @@ M: #if mark-live-values* look-at-inputs ;
|
||||||
M: #dispatch mark-live-values* look-at-inputs ;
|
M: #dispatch mark-live-values* look-at-inputs ;
|
||||||
|
|
||||||
: look-at-phi ( value outputs inputs -- )
|
: look-at-phi ( value outputs inputs -- )
|
||||||
[ index ] dip swap dup [ <column> look-at-values ] [ 2drop ] if ;
|
[ index ] dip swap [ <column> look-at-values ] [ drop ] if* ;
|
||||||
|
|
||||||
M: #phi compute-live-values*
|
M: #phi compute-live-values*
|
||||||
#! If any of the outputs of a #phi are live, then the
|
#! If any of the outputs of a #phi are live, then the
|
||||||
|
|
|
@ -84,7 +84,7 @@ CONSTANT: revalidate-url-key "__u"
|
||||||
] with-exit-continuation ;
|
] with-exit-continuation ;
|
||||||
|
|
||||||
: handle-rest ( path action -- )
|
: handle-rest ( path action -- )
|
||||||
rest>> dup [ [ "/" join ] dip set-param ] [ 2drop ] if ;
|
rest>> [ [ "/" join ] dip set-param ] [ drop ] if* ;
|
||||||
|
|
||||||
: init-action ( path action -- )
|
: init-action ( path action -- )
|
||||||
begin-form
|
begin-form
|
||||||
|
|
|
@ -20,7 +20,7 @@ scope f
|
||||||
t >>changed? drop ;
|
t >>changed? drop ;
|
||||||
|
|
||||||
: scope-get ( key scope -- value )
|
: scope-get ( key scope -- value )
|
||||||
dup [ namespace>> at ] [ 2drop f ] if ;
|
[ namespace>> at ] [ drop f ] if* ;
|
||||||
|
|
||||||
: scope-set ( value key scope -- )
|
: scope-set ( value key scope -- )
|
||||||
[ namespace>> set-at ] [ scope-changed ] bi ;
|
[ namespace>> set-at ] [ scope-changed ] bi ;
|
||||||
|
|
|
@ -124,7 +124,7 @@ M: fd drain
|
||||||
M: unix (wait-to-write) ( port -- )
|
M: unix (wait-to-write) ( port -- )
|
||||||
dup
|
dup
|
||||||
dup handle>> check-disposed drain
|
dup handle>> check-disposed drain
|
||||||
dup [ wait-for-port ] [ 2drop ] if ;
|
[ wait-for-port ] [ drop ] if* ;
|
||||||
|
|
||||||
M: unix io-multiplex ( nanos -- )
|
M: unix io-multiplex ( nanos -- )
|
||||||
mx get-global wait-for-events ;
|
mx get-global wait-for-events ;
|
||||||
|
|
|
@ -103,7 +103,7 @@ PRIVATE>
|
||||||
ERROR: file-not-found path bfs? quot ;
|
ERROR: file-not-found path bfs? quot ;
|
||||||
|
|
||||||
: find-file-throws ( path bfs? quot -- path )
|
: find-file-throws ( path bfs? quot -- path )
|
||||||
3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline
|
3dup find-file [ 2nip nip ] [ file-not-found ] if* ; inline
|
||||||
|
|
||||||
ERROR: sequence-expected obj ;
|
ERROR: sequence-expected obj ;
|
||||||
|
|
||||||
|
|
|
@ -47,7 +47,7 @@ M: secure (accept)
|
||||||
|
|
||||||
: (shutdown) ( handle -- )
|
: (shutdown) ( handle -- )
|
||||||
dup dup handle>> SSL_shutdown check-shutdown-response
|
dup dup handle>> SSL_shutdown check-shutdown-response
|
||||||
dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;
|
[ dupd wait-for-fd (shutdown) ] [ drop ] if* ;
|
||||||
|
|
||||||
M: ssl-handle shutdown
|
M: ssl-handle shutdown
|
||||||
dup connected>> [
|
dup connected>> [
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: locals.rewrite.point-free
|
||||||
|
|
||||||
: local-index ( args obj -- n )
|
: local-index ( args obj -- n )
|
||||||
2dup '[ unquote _ eq? ] find drop
|
2dup '[ unquote _ eq? ] find drop
|
||||||
dup [ 2nip ] [ drop bad-local ] if ;
|
[ 2nip ] [ bad-local ] if* ;
|
||||||
|
|
||||||
: read-local-quot ( args obj -- quot )
|
: read-local-quot ( args obj -- quot )
|
||||||
local-index neg [ get-local ] curry ;
|
local-index neg [ get-local ] curry ;
|
||||||
|
|
|
@ -81,7 +81,7 @@ SYMBOL: matrix
|
||||||
[
|
[
|
||||||
rows iota <reversed> [
|
rows iota <reversed> [
|
||||||
dup nth-row leading drop
|
dup nth-row leading drop
|
||||||
dup [ swap dup iota clear-col ] [ 2drop ] if
|
[ swap dup iota clear-col ] [ drop ] if*
|
||||||
] each
|
] each
|
||||||
] with-matrix ;
|
] with-matrix ;
|
||||||
|
|
||||||
|
@ -96,7 +96,7 @@ SYMBOL: matrix
|
||||||
dup first length identity-matrix [
|
dup first length identity-matrix [
|
||||||
[
|
[
|
||||||
dup leading drop
|
dup leading drop
|
||||||
dup [ basis-vector ] [ 2drop ] if
|
[ basis-vector ] [ drop ] if*
|
||||||
] each
|
] each
|
||||||
] with-matrix flip nonzero-rows
|
] with-matrix flip nonzero-rows
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
|
@ -14,7 +14,7 @@ C: <mirror> mirror
|
||||||
|
|
||||||
M: mirror at*
|
M: mirror at*
|
||||||
[ nip object>> ] [ object-slots slot-named ] 2bi
|
[ nip object>> ] [ object-slots slot-named ] 2bi
|
||||||
dup [ offset>> slot t ] [ 2drop f f ] if ;
|
[ offset>> slot t ] [ drop f f ] if* ;
|
||||||
|
|
||||||
ERROR: no-such-slot slot ;
|
ERROR: no-such-slot slot ;
|
||||||
ERROR: read-only-slot slot ;
|
ERROR: read-only-slot slot ;
|
||||||
|
|
|
@ -15,7 +15,7 @@ SYMBOLS: +bottom+ +top+ ;
|
||||||
: unify-inputs ( max-input-count input-count meta-d -- new-meta-d )
|
: unify-inputs ( max-input-count input-count meta-d -- new-meta-d )
|
||||||
! Introduced values can be anything, and don't unify with
|
! Introduced values can be anything, and don't unify with
|
||||||
! literals.
|
! literals.
|
||||||
dup [ [ - +top+ <repetition> ] dip append ] [ 3drop f ] if ;
|
[ [ - +top+ <repetition> ] dip append ] [ 2drop f ] if* ;
|
||||||
|
|
||||||
: pad-with-bottom ( seq -- newseq )
|
: pad-with-bottom ( seq -- newseq )
|
||||||
! Terminated branches are padded with bottom values which
|
! Terminated branches are padded with bottom values which
|
||||||
|
|
|
@ -12,7 +12,7 @@ IN: ui.backend.cocoa.views
|
||||||
|
|
||||||
: send-mouse-moved ( view event -- )
|
: send-mouse-moved ( view event -- )
|
||||||
[ mouse-location ] [ drop window ] 2bi
|
[ mouse-location ] [ drop window ] 2bi
|
||||||
dup [ move-hand fire-motion yield ] [ 2drop ] if ;
|
[ move-hand fire-motion yield ] [ drop ] if* ;
|
||||||
|
|
||||||
: button ( event -- n )
|
: button ( event -- n )
|
||||||
#! Cocoa -> Factor UI button mapping
|
#! Cocoa -> Factor UI button mapping
|
||||||
|
@ -68,7 +68,7 @@ CONSTANT: key-codes
|
||||||
[ event-modifiers ] [ key-code ] bi ;
|
[ event-modifiers ] [ key-code ] bi ;
|
||||||
|
|
||||||
: send-key-event ( view gesture -- )
|
: send-key-event ( view gesture -- )
|
||||||
swap window dup [ propagate-key-gesture ] [ 2drop ] if ;
|
swap window [ propagate-key-gesture ] [ drop ] if* ;
|
||||||
|
|
||||||
: interpret-key-event ( view event -- )
|
: interpret-key-event ( view event -- )
|
||||||
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
|
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
|
||||||
|
@ -89,21 +89,21 @@ CONSTANT: key-codes
|
||||||
[ mouse-location ]
|
[ mouse-location ]
|
||||||
[ drop window ]
|
[ drop window ]
|
||||||
2tri
|
2tri
|
||||||
dup [ send-button-down ] [ 3drop ] if ;
|
[ send-button-down ] [ 2drop ] if* ;
|
||||||
|
|
||||||
: send-button-up$ ( view event -- )
|
: send-button-up$ ( view event -- )
|
||||||
[ nip mouse-event>gesture <button-up> ]
|
[ nip mouse-event>gesture <button-up> ]
|
||||||
[ mouse-location ]
|
[ mouse-location ]
|
||||||
[ drop window ]
|
[ drop window ]
|
||||||
2tri
|
2tri
|
||||||
dup [ send-button-up ] [ 3drop ] if ;
|
[ send-button-up ] [ 2drop ] if* ;
|
||||||
|
|
||||||
: send-scroll$ ( view event -- )
|
: send-scroll$ ( view event -- )
|
||||||
[ nip [ -> deltaX ] [ -> deltaY ] bi [ neg ] bi@ 2array ]
|
[ nip [ -> deltaX ] [ -> deltaY ] bi [ neg ] bi@ 2array ]
|
||||||
[ mouse-location ]
|
[ mouse-location ]
|
||||||
[ drop window ]
|
[ drop window ]
|
||||||
2tri
|
2tri
|
||||||
dup [ send-scroll ] [ 3drop ] if ;
|
[ send-scroll ] [ 2drop ] if* ;
|
||||||
|
|
||||||
: send-action$ ( view event gesture -- )
|
: send-action$ ( view event gesture -- )
|
||||||
[ drop window ] dip over [ send-action ] [ 2drop ] if ;
|
[ drop window ] dip over [ send-action ] [ 2drop ] if ;
|
||||||
|
|
|
@ -77,10 +77,10 @@ C: <button-pen> button-pen
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
M: button-pen draw-interior
|
M: button-pen draw-interior
|
||||||
lookup-button-pen dup [ draw-interior ] [ 2drop ] if ;
|
lookup-button-pen [ draw-interior ] [ drop ] if* ;
|
||||||
|
|
||||||
M: button-pen draw-boundary
|
M: button-pen draw-boundary
|
||||||
lookup-button-pen dup [ draw-boundary ] [ 2drop ] if ;
|
lookup-button-pen [ draw-boundary ] [ drop ] if* ;
|
||||||
|
|
||||||
M: button-pen pen-pref-dim
|
M: button-pen pen-pref-dim
|
||||||
[
|
[
|
||||||
|
|
|
@ -56,9 +56,9 @@ M: vocab-completion (word-at-caret)
|
||||||
drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
|
drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
|
||||||
|
|
||||||
M: word-completion (word-at-caret)
|
M: word-completion (word-at-caret)
|
||||||
manifest>> dup [
|
manifest>> [
|
||||||
'[ _ _ search-manifest ] [ drop f ] recover
|
'[ _ _ search-manifest ] [ drop f ] recover
|
||||||
] [ 2drop f ] if ;
|
] [ drop f ] if* ;
|
||||||
|
|
||||||
M: char-completion (word-at-caret) 2drop f ;
|
M: char-completion (word-at-caret) 2drop f ;
|
||||||
|
|
||||||
|
@ -368,7 +368,7 @@ M: interactor stream-read-quot
|
||||||
: interactor-operation ( gesture interactor -- ? )
|
: interactor-operation ( gesture interactor -- ? )
|
||||||
[ token-model>> value>> ] keep word-at-caret
|
[ token-model>> value>> ] keep word-at-caret
|
||||||
[ nip ] [ gesture>operation ] 2bi
|
[ nip ] [ gesture>operation ] 2bi
|
||||||
dup [ invoke-command f ] [ 2drop t ] if ;
|
[ invoke-command f ] [ drop t ] if* ;
|
||||||
|
|
||||||
M: interactor handle-gesture
|
M: interactor handle-gesture
|
||||||
{
|
{
|
||||||
|
|
|
@ -47,7 +47,7 @@ M: unrolled-list clear-deque
|
||||||
unroll-factor 0 <array>
|
unroll-factor 0 <array>
|
||||||
[ unroll-factor 1 - swap set-nth ] keep f
|
[ unroll-factor 1 - swap set-nth ] keep f
|
||||||
] dip [ node boa dup ] keep
|
] dip [ node boa dup ] keep
|
||||||
dup [ prev<< ] [ 2drop ] if ; inline
|
[ prev<< ] [ drop ] if* ; inline
|
||||||
|
|
||||||
: normalize-back ( list -- )
|
: normalize-back ( list -- )
|
||||||
dup back>> [
|
dup back>> [
|
||||||
|
@ -93,7 +93,7 @@ M: unrolled-list pop-front*
|
||||||
[
|
[
|
||||||
unroll-factor 0 <array> [ set-first ] keep
|
unroll-factor 0 <array> [ set-first ] keep
|
||||||
] dip [ f node boa dup ] keep
|
] dip [ f node boa dup ] keep
|
||||||
dup [ next<< ] [ 2drop ] if ; inline
|
[ next<< ] [ drop ] if* ; inline
|
||||||
|
|
||||||
: normalize-front ( list -- )
|
: normalize-front ( list -- )
|
||||||
dup front>> [
|
dup front>> [
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays assocs combinators.short-circuit fry
|
USING: accessors arrays assocs combinators.short-circuit fry
|
||||||
io.directories io.files io.files.types io.pathnames kernel make
|
io.directories io.files io.files.types io.pathnames kernel make
|
||||||
memoize namespaces sequences sorting splitting vocabs sets
|
memoize namespaces sequences sets sorting splitting vocabs
|
||||||
vocabs.loader vocabs.metadata ;
|
vocabs.loader vocabs.metadata ;
|
||||||
IN: vocabs.hierarchy
|
IN: vocabs.hierarchy
|
||||||
|
|
||||||
|
@ -153,6 +153,8 @@ PRIVATE>
|
||||||
: load-all ( -- )
|
: load-all ( -- )
|
||||||
"" load ;
|
"" load ;
|
||||||
|
|
||||||
MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;
|
MEMO: all-tags ( -- seq )
|
||||||
|
[ vocab-tags ] collect-vocabs ;
|
||||||
|
|
||||||
MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;
|
MEMO: all-authors ( -- seq )
|
||||||
|
[ vocab-authors ] collect-vocabs ;
|
||||||
|
|
|
@ -33,7 +33,7 @@ IN: xmode.marker
|
||||||
[
|
[
|
||||||
dup [ digit? ] all? [
|
dup [ digit? ] all? [
|
||||||
current-rule-set digit-re>>
|
current-rule-set digit-re>>
|
||||||
dup [ dupd matches? ] [ drop f ] if
|
[ dupd matches? ] [ f ] if*
|
||||||
] unless*
|
] unless*
|
||||||
]
|
]
|
||||||
} 0&& nip ;
|
} 0&& nip ;
|
||||||
|
@ -130,25 +130,25 @@ GENERIC: handle-rule-end ( match-count rule -- )
|
||||||
: check-escape-rule ( rule -- ? )
|
: check-escape-rule ( rule -- ? )
|
||||||
no-escape?>> [ f ] [
|
no-escape?>> [ f ] [
|
||||||
find-escape-rule dup [
|
find-escape-rule dup [
|
||||||
dup rule-start-matches? dup [
|
dup rule-start-matches? [
|
||||||
swap handle-rule-start
|
swap handle-rule-start
|
||||||
delegate-end-escaped? toggle
|
delegate-end-escaped? toggle
|
||||||
t
|
t
|
||||||
] [
|
] [
|
||||||
2drop f
|
drop f
|
||||||
] if
|
] if*
|
||||||
] when
|
] when
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: check-every-rule ( -- ? )
|
: check-every-rule ( -- ? )
|
||||||
current-char current-rule-set get-rules
|
current-char current-rule-set get-rules
|
||||||
[ rule-start-matches? ] map-find
|
[ rule-start-matches? ] map-find
|
||||||
dup [ handle-rule-start t ] [ 2drop f ] if ;
|
[ handle-rule-start t ] [ drop f ] if* ;
|
||||||
|
|
||||||
: ?end-rule ( -- )
|
: ?end-rule ( -- )
|
||||||
current-rule [
|
current-rule [
|
||||||
dup rule-end-matches?
|
dup rule-end-matches?
|
||||||
dup [ swap handle-rule-end ] [ 2drop ] if
|
[ swap handle-rule-end ] [ drop ] if*
|
||||||
] when* ;
|
] when* ;
|
||||||
|
|
||||||
: rule-match-token* ( rule -- id )
|
: rule-match-token* ( rule -- id )
|
||||||
|
@ -213,7 +213,7 @@ M: mark-previous-rule handle-rule-start
|
||||||
: check-end-delegate ( -- ? )
|
: check-end-delegate ( -- ? )
|
||||||
context get parent>> [
|
context get parent>> [
|
||||||
in-rule>> [
|
in-rule>> [
|
||||||
dup rule-end-matches? dup [
|
dup rule-end-matches? [
|
||||||
[
|
[
|
||||||
swap handle-rule-end
|
swap handle-rule-end
|
||||||
?end-rule
|
?end-rule
|
||||||
|
@ -223,7 +223,7 @@ M: mark-previous-rule handle-rule-start
|
||||||
rule-match-token* next-token,
|
rule-match-token* next-token,
|
||||||
pop-context
|
pop-context
|
||||||
seen-whitespace-end? on t
|
seen-whitespace-end? on t
|
||||||
] [ drop check-escape-rule ] if
|
] [ check-escape-rule ] if*
|
||||||
] [ f ] if*
|
] [ f ] if*
|
||||||
] [ f ] if* ;
|
] [ f ] if* ;
|
||||||
|
|
||||||
|
|
|
@ -132,7 +132,7 @@ SYMBOL: +incomparable+
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: superclass<= ( first second -- ? )
|
: superclass<= ( first second -- ? )
|
||||||
swap superclass-of dup [ swap class<= ] [ 2drop f ] if ;
|
swap superclass-of [ swap class<= ] [ drop f ] if* ;
|
||||||
|
|
||||||
: left-anonymous-union<= ( first second -- ? )
|
: left-anonymous-union<= ( first second -- ? )
|
||||||
[ members>> ] dip [ class<= ] curry all? ;
|
[ members>> ] dip [ class<= ] curry all? ;
|
||||||
|
|
|
@ -184,7 +184,7 @@ M: sequence implementors [ implementors ] gather ;
|
||||||
GENERIC: metaclass-changed ( use class -- )
|
GENERIC: metaclass-changed ( use class -- )
|
||||||
|
|
||||||
: ?metaclass-changed ( class usages/f -- )
|
: ?metaclass-changed ( class usages/f -- )
|
||||||
dup [ [ metaclass-changed ] with each ] [ 2drop ] if ;
|
[ [ metaclass-changed ] with each ] [ drop ] if* ;
|
||||||
|
|
||||||
: check-metaclass ( class metaclass -- usages/f )
|
: check-metaclass ( class metaclass -- usages/f )
|
||||||
over class? [
|
over class? [
|
||||||
|
|
|
@ -60,7 +60,8 @@ PRIVATE>
|
||||||
method-classes interesting-classes smallest-class ;
|
method-classes interesting-classes smallest-class ;
|
||||||
|
|
||||||
: method-for-class ( class generic -- method/f )
|
: method-for-class ( class generic -- method/f )
|
||||||
[ nip ] [ nearest-class ] 2bi dup [ swap ?lookup-method ] [ 2drop f ] if ;
|
[ nip ] [ nearest-class ] 2bi
|
||||||
|
[ swap ?lookup-method ] [ drop f ] if* ;
|
||||||
|
|
||||||
GENERIC: effective-method ( generic -- method )
|
GENERIC: effective-method ( generic -- method )
|
||||||
|
|
||||||
|
|
|
@ -56,7 +56,7 @@ PRIVATE>
|
||||||
] cache ;
|
] cache ;
|
||||||
|
|
||||||
: vocab-append-path ( vocab path -- newpath )
|
: vocab-append-path ( vocab path -- newpath )
|
||||||
swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ;
|
swap find-vocab-root [ prepend-path ] [ drop f ] if* ;
|
||||||
|
|
||||||
: vocab-source-path ( vocab -- path/f )
|
: vocab-source-path ( vocab -- path/f )
|
||||||
dup ".factor" append-vocab-dir vocab-append-path ;
|
dup ".factor" append-vocab-dir vocab-append-path ;
|
||||||
|
@ -139,7 +139,7 @@ SYMBOL: blacklist
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: add-to-blacklist ( error vocab -- )
|
: add-to-blacklist ( error vocab -- )
|
||||||
vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
|
vocab-name blacklist get [ set-at ] [ 2drop ] if* ;
|
||||||
|
|
||||||
GENERIC: (require) ( name -- )
|
GENERIC: (require) ( name -- )
|
||||||
|
|
||||||
|
|
|
@ -201,7 +201,7 @@ TUPLE: ambiguous-use-error words ;
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: search-manifest ( name manifest -- word/f )
|
: search-manifest ( name manifest -- word/f )
|
||||||
2dup qualified-search dup [ 2nip ] [ drop vocab-search ] if ;
|
2dup qualified-search [ 2nip ] [ vocab-search ] if* ;
|
||||||
|
|
||||||
: search ( name -- word/f )
|
: search ( name -- word/f )
|
||||||
manifest get search-manifest ;
|
manifest get search-manifest ;
|
||||||
|
|
|
@ -12,7 +12,7 @@ IN: sequences.abbrev
|
||||||
[ prefixes ] keep 1array '[ _ ] H{ } map>assoc ;
|
[ prefixes ] keep 1array '[ _ ] H{ } map>assoc ;
|
||||||
|
|
||||||
: assoc-merge ( assoc1 assoc2 -- assoc3 )
|
: assoc-merge ( assoc1 assoc2 -- assoc3 )
|
||||||
[ '[ over _ at dup [ append ] [ drop ] if ] assoc-map ] keep swap assoc-union ;
|
[ '[ over _ at [ append ] when* ] assoc-map ] keep swap assoc-union ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -32,7 +32,7 @@ CONSTANT: empty-lexenv T{ lexenv }
|
||||||
: ivar-reader ( name lexenv -- quot/f )
|
: ivar-reader ( name lexenv -- quot/f )
|
||||||
dup class>> [
|
dup class>> [
|
||||||
[ class>> "slots" word-prop slot-named ] [ self>> ] bi
|
[ class>> "slots" word-prop slot-named ] [ self>> ] bi
|
||||||
swap dup [ name>> reader-word [ ] 2sequence ] [ 2drop f ] if
|
swap [ name>> reader-word [ ] 2sequence ] [ drop f ] if*
|
||||||
] [ 2drop f ] if ;
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
: class-name ( name -- quot/f )
|
: class-name ( name -- quot/f )
|
||||||
|
@ -56,7 +56,7 @@ M: bad-identifier summary drop "Unknown identifier" ;
|
||||||
: ivar-writer ( name lexenv -- quot/f )
|
: ivar-writer ( name lexenv -- quot/f )
|
||||||
dup class>> [
|
dup class>> [
|
||||||
[ class>> "slots" word-prop slot-named ] [ self>> ] bi
|
[ class>> "slots" word-prop slot-named ] [ self>> ] bi
|
||||||
swap dup [ name>> writer-word [ ] 2sequence ] [ 2drop f ] if
|
swap [ name>> writer-word [ ] 2sequence ] [ drop f ] if*
|
||||||
] [ 2drop f ] if ;
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
: lookup-writer ( name lexenv -- writer-quot )
|
: lookup-writer ( name lexenv -- writer-quot )
|
||||||
|
|
Loading…
Reference in New Issue