<PRIVATE
: init-struct ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
- '[ [ struct-prototype ] _ _ ??if ] keep memory>struct ; inline
+ '[ dup struct-prototype _ _ ?if-old ] keep memory>struct ; inline
PRIVATE>
: ?pasteboard-string ( pboard error -- str/f )
over pasteboard-string? [
- swap pasteboard-string [ ] [ pasteboard-error ] ?if
+ swap pasteboard-string [ ] [ pasteboard-error ] ?if-old
] [
nip pasteboard-error
] if ;
[ [ cc= ^^compare-integer ] binary-op ] [ [ cc= ^^compare ] binary-op ] if ;
: emit-special-object ( block node -- block' )
- [ node-input-infos first literal>> ] [
+ dup node-input-infos first literal>> [
ds-drop
vm-special-object-offset ^^vm-field
ds-push
- ] [ emit-primitive ] ??if ;
+ ] [ emit-primitive ] ?if-old ;
: emit-set-special-object ( block node -- block' )
- [ node-input-infos second literal>> ] [
+ dup node-input-infos second literal>> [
ds-drop
[ ds-pop ] dip vm-special-object-offset ##set-vm-field,
- ] [ emit-primitive ] ??if ;
+ ] [ emit-primitive ] ?if-old ;
: context-object-offset ( n -- n )
cells "context-objects" context offset-of + ;
: emit-context-object ( block node -- block' )
- [ node-input-infos first literal>> ] [
+ dup node-input-infos first literal>> [
"ctx" vm offset-of ^^vm-field
ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
- ] [ emit-primitive ] ??if ;
+ ] [ emit-primitive ] ?if-old ;
: emit-identity-hashcode ( -- )
[
insn ;
: check-redundancy ( insn -- insn' )
- dup >expr
- [ exprs>vns get at ]
- [ redundant-instruction ] [ useful-instruction ] ??if ;
+ dup >expr dup exprs>vns get at
+ [ redundant-instruction ] [ useful-instruction ] ?if-old ;
M: insn process-instruction
- [ rewrite ] [ process-instruction ] ?when ;
+ dup rewrite [ process-instruction ] [ ] ?if-old ;
M: foldable-insn process-instruction
- [ rewrite ]
+ dup rewrite
[ process-instruction ]
- [ dup defs-vregs length 1 = [ check-redundancy ] when ] ??if ;
+ [ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if-old ;
M: ##copy process-instruction
dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
: default-output-value-infos ( #call word -- infos )
"default-output-classes" word-prop
- [ class-infos ] [ out-d>> length object-info <repetition> ] ?if ;
+ [ class-infos ] [ out-d>> length object-info <repetition> ] ?if-old ;
: output-value-infos ( #call word -- infos )
{
GENERIC: mailbox-of ( thread -- mailbox )
M: thread mailbox-of
- [ mailbox>> ]
+ dup mailbox>>
[ { mailbox } declare ]
- [ <mailbox> [ >>mailbox drop ] keep ] ??if ; inline
+ [ <mailbox> [ >>mailbox drop ] keep ] ?if-old ; inline
M: thread send
mailbox-of mailbox-put ;
: load-framework ( name -- )
[ <CFBundle> ]
[ CFBundleLoadExecutable drop ]
- [ "Cannot load bundle named " prepend throw ] ??if ;
+ [ "Cannot load bundle named " prepend throw ] ?if ;
{ float-rep [ LFS ] }
{ double-rep [ LFD ] }
} case
- ] ?if ;
+ ] ?if-old ;
M: ppc.64 %load-memory-imm
[
{ float-rep [ [ scratch-reg ] dip LI scratch-reg LFSX ] }
{ double-rep [ [ scratch-reg ] dip LI scratch-reg LFDX ] }
} case
- ] ?if ;
+ ] ?if-old ;
M: ppc.32 %load-memory
{ float-rep [ LFSX ] }
{ double-rep [ LFDX ] }
} case
- ] ?if ;
+ ] ?if-old ;
M: ppc.64 %load-memory
[ [ 0 assert= ] bi@ ] 2dip
{ float-rep [ LFSX ] }
{ double-rep [ LFDX ] }
} case
- ] ?if ;
+ ] ?if-old ;
M: ppc.32 %store-memory-imm
{ float-rep [ STFS ] }
{ double-rep [ STFD ] }
} case
- ] ?if ;
+ ] ?if-old ;
M: ppc.64 %store-memory-imm
[
{ float-rep [ [ scratch-reg ] dip LI scratch-reg STFSX ] }
{ double-rep [ [ scratch-reg ] dip LI scratch-reg STFDX ] }
} case
- ] ?if ;
+ ] ?if-old ;
M: ppc.32 %store-memory
[ [ 0 assert= ] bi@ ] 2dip
{ float-rep [ STFSX ] }
{ double-rep [ STFDX ] }
} case
- ] ?if ;
+ ] ?if-old ;
M: ppc.64 %store-memory
[ [ 0 assert= ] bi@ ] 2dip
{ float-rep [ STFSX ] }
{ double-rep [ STFDX ] }
} case
- ] ?if ;
+ ] ?if-old ;
M:: ppc %allot ( dst size class nursery-ptr -- )
! dst = vm->nursery.here;
{ c:int [ 32 %alien-signed-getter ] }
{ c:uint [ 32 [ 2drop ] %alien-integer-getter ] }
} case
- ] [ nipd %copy ] ?if ;
+ ] [ nipd %copy ] ?if-old ;
M: x86 %load-memory
(%memory) (%load-memory) ;
{ c:int [ 32 %alien-integer-setter ] }
{ c:uint [ 32 %alien-integer-setter ] }
} case
- ] [ [ nip swap ] dip %copy ] ?if ;
+ ] [ [ nip swap ] dip %copy ] ?if-old ;
M: x86 %store-memory
(%memory) (%store-memory) ;
GENERIC: edit ( object -- )
M: object edit
- [ where ] [ first2 edit-location ] [ cannot-find-source ] ??if ;
+ [ where ] [ first2 edit-location ] [ cannot-find-source ] ?if ;
M: string edit edit-vocab ;
{ "count*" { "percent-of" "0.99" } }
{ "more?" { "deref?" "0.99" } }
{ "plox" { "?transmute" "0.99" } }
+ { "?if" { "?if-old" "0.99" } }
}
: compute-assoc-fixups ( continuation name assoc -- seq )
: end-aside ( default -- response )
[ drop aside-id get aside-id off get-aside ]
- [ move-on ] [ <redirect> ] ??if ;
+ [ move-on ] [ <redirect> ] ?if ;
M: asides link-attr
drop
: base-path ( string -- seq )
dup responder-nesting get
[ second class-of superclasses-of [ name>> = ] with any? ] with find nip
- [ first ] [ no-such-responder ] ?if ;
+ [ first ] [ no-such-responder ] ?if-old ;
: resolve-base-path ( string -- string' )
"$" ?head [
: defer-boxeds ( boxeds -- )
[
[
- dup find-existing-boxed-type
- [ ] [ c-type>> defer-c-type ] ?if
+ [ find-existing-boxed-type ]
+ [ c-type>> defer-c-type ] ?unless
]
[ name>> qualified-name ] bi
boxed-info new swap register-type
: escape-char ( ch -- )
dup ascii? [
- dup H{
- { CHAR: \" "__quo__" }
- { CHAR: * "__star__" }
- { CHAR: : "__colon__" }
- { CHAR: < "__lt__" }
- { CHAR: > "__gt__" }
- { CHAR: ? "__que__" }
- { CHAR: \\ "__back__" }
- { CHAR: | "__pipe__" }
- { CHAR: / "__slash__" }
- { CHAR: , "__comma__" }
- { CHAR: @ "__at__" }
- { CHAR: # "__hash__" }
- { CHAR: % "__percent__" }
- } at [ % ] [ , ] ?if
+ [
+ H{
+ { CHAR: \" "__quo__" }
+ { CHAR: * "__star__" }
+ { CHAR: : "__colon__" }
+ { CHAR: < "__lt__" }
+ { CHAR: > "__gt__" }
+ { CHAR: ? "__que__" }
+ { CHAR: \\ "__back__" }
+ { CHAR: | "__pipe__" }
+ { CHAR: / "__slash__" }
+ { CHAR: , "__comma__" }
+ { CHAR: @ "__at__" }
+ { CHAR: # "__hash__" }
+ { CHAR: % "__percent__" }
+ } at
+ ] [ % ] [ , ] ?if
] [ number>string "__" "__" surround % ] if ;
: escape-filename ( string -- filename )
: describe-help ( vocab -- )
[
- dup vocab-help
+ [ vocab-help ]
[ "Documentation" $heading ($link) ]
[ "Summary" $heading vocab-summary print-element ]
?if
CHLOE: style
[ "include" optional-attr ]
[ utf8 file-contents [ add-style ] [code-with] ]
- [ compile-children>string [ add-style ] [code] ] ??if ;
+ [ compile-children>string [ add-style ] [code] ] ?if ;
CHLOE: write-style
drop [
CHLOE: script
[ "include" optional-attr ]
[ utf8 file-contents [ add-script ] [code-with] ]
- [ compile-children>string [ add-script ] [code] ] ??if ;
+ [ compile-children>string [ add-script ] [code] ] ?if ;
CHLOE: write-script
drop [
[ chloe-tags get at ]
[ call( tag -- ) ]
[ unknown-chloe-tag ]
- ??if ;
+ ?if ;
: compile-string ( string -- )
string-context? get [ escape-string ] unless [write] ;
: required-attr ( tag name -- value )
[ nip ] [ chloe-name attr ] 2bi
- [ ] [ " attribute is required" append throw ] ?if ;
+ [ ] [ " attribute is required" append throw ] ?if-old ;
: optional-attr ( tag name -- value )
chloe-name attr ;
: serve-file ( filename -- response )
dup mime-type
dup file-responder get special>> at
- [ call( filename -- response ) ] [ serve-static ] ?if ;
+ [ call( filename -- response ) ] [ serve-static ] ?if-old ;
\ serve-file NOTICE add-input-logging
: serve-directory ( filename -- response )
url get path>> "/" tail? [
dup
- find-index [ serve-file ] [ list-directory ] ?if
+ find-index [ serve-file ] [ list-directory ] ?if-old
] [
drop
url get clone [ "/" append ] change-path <permanent-redirect>
[
>string dup string>number
[ 1 + stack-var boa ]
- [ [ anon-var new ] [ named-var boa ] if-empty ] ?if ,
+ [ [ anon-var new ] [ named-var boa ] if-empty ] ?if-old ,
]
[ (parse-interpolate) ] bi*
] when*
[ interpolate ] with-string-writer ; inline
: interpolate-locals-quot ( str -- quot )
- [ dup search [ [ ] ] [ [ get ] ] ?if ] (interpolate-quot) ;
+ [ dup search [ [ ] ] [ [ get ] ] ?if-old ] (interpolate-quot) ;
MACRO: interpolate-locals ( str -- quot )
interpolate-locals-quot ;
M: gb18030 encode-char
drop [
- dup mapping get-global at
- [ ] [ lookup-range ] ?if
+ [ mapping get-global at ] [ lookup-range ] ?unless
] dip stream-write ;
: second-byte? ( ch -- ? ) ! of a double-byte character
linear dup gb>u get-global interval-at [
[ bfirst>> - ] [ ufirst>> ] bi +
] [ drop replacement-char ] if*
- ] ?if ;
+ ] ?if-old ;
: four-byte ( stream byte1 byte2 -- char )
rot 2 swap stream-read dup last-bytes?
[ handle>> ] dip
[
'[
- _ dup get-session
- [ resume-session ] [ begin-session ] ?if
+ _
+ [ get-session ] [ resume-session ] [ begin-session ] ?if
] with-timeout
] [ drop t >>connected drop ] 2bi ;
: ipv4-component ( str -- n )
dup dup octal? [ oct> ] [ string>number ] if
- [ ] [ bad-ipv4-component ] ?if ;
+ [ ] [ bad-ipv4-component ] ?if-old ;
: split-ipv4 ( str -- array )
"." split [ ipv4-component ] map ;
<PRIVATE
: ipv6-component ( str -- n )
- dup hex> [ ] [ bad-ipv6-component ] ?if ;
+ dup hex> [ ] [ bad-ipv6-component ] ?if-old ;
: split-ipv6 ( string -- seq )
":" split CHAR: . over last member? [ unclip-last ] [ f ] if
{ "Infinity" [ 1/0. ] }
{ "-Infinity" [ -1/0. ] }
{ "NaN" [ 0/0. ] }
- [ dup string>number [ ] [ not-a-json-number ] ?if ]
+ [ dup string>number [ ] [ not-a-json-number ] ?if-old ]
} case
] dip ;
first2
[ [ dupd match ] curry ] dip
[ with-variables ] curry rot
- [ ?if ] 2curry append
+ [ ?if-old ] 2curry append
] reduce ;
GENERIC: replace-patterns ( object -- result )
2drop f f
] [
2dup length head over match
- [ swap ?rest ] [ [ rest ] dip (match-first) ] ?if
+ [ swap ?rest ] [ [ rest ] dip (match-first) ] ?if-old
] if ;
: match-first ( seq pattern-seq -- bindings )
M: word integer-op-input-classes
dup "input-classes" word-prop
- [ ] [ bad-integer-op ] ?if ;
+ [ ] [ bad-integer-op ] ?if-old ;
: generic-variant ( op -- generic-op/f )
- dup "derived-from" word-prop [ first ] [ ] ?if ;
+ dup "derived-from" word-prop [ first ] [ ] ?if-old ;
: no-overflow-variant ( op -- fast-op )
H{
def call compile :> compiled-def
word [
dup compiled-def compiled-parse
- [ ast>> ] [ word parse-failed ] ?if
+ [ ast>> ] [ word parse-failed ] ?if-old
] effect define-declared
] with-compilation-unit
] append!
new-child
] [
[ nip ] 2keep children>> last (ppush-new-tail)
- [ swap new-child ] [ swap node-set-last f ] ?if
+ [ swap new-child ] [ swap node-set-last f ] ?if-old
] if ;
: do-expansion ( pvec root expansion/f -- pvec )
{ [ "script=" ?head ] [
dup simple-script-table at
[ <script-class> ]
- [ "script=" prepend bad-class ] ?if
+ [ "script=" prepend bad-class ] ?if-old
] }
[ bad-class ]
} cond ;
: unicode-class ( name -- class )
- dup parse-unicode-class [ ] [ bad-class ] ?if ;
+ dup parse-unicode-class [ ] [ bad-class ] ?if-old ;
: name>class ( name -- class )
>string simple {
ERROR: nonexistent-option name ;
: ch>option ( ch -- singleton )
- dup options-assoc at [ ] [ nonexistent-option ] ?if ;
+ dup options-assoc at [ ] [ nonexistent-option ] ?if-old ;
: option>ch ( option -- string )
options-assoc value-at ;
M: c-type-word c-array-constructor
underlying-type
dup [ name>> "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ specialized-array-vocab-not-loaded ] ?if-old ; foldable
M: pointer c-array-constructor drop void* c-array-constructor ;
M: c-type-word c-(array)-constructor
underlying-type
dup [ name>> "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ specialized-array-vocab-not-loaded ] ?if-old ; foldable
M: pointer c-(array)-constructor drop void* c-(array)-constructor ;
M: c-type-word c-direct-array-constructor
underlying-type
dup [ name>> "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ specialized-array-vocab-not-loaded ] ?if-old ; foldable
M: pointer c-direct-array-constructor drop void* c-direct-array-constructor ;
M: c-type-word c-array-type
underlying-type
dup [ name>> "-array" append ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ specialized-array-vocab-not-loaded ] ?if-old ; foldable
M: pointer c-array-type drop void* c-array-type ;
M: c-type-word c-array-type?
underlying-type
dup [ name>> "-array?" append ] [ specialized-array-vocab ] bi lookup-word
- [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+ [ ] [ specialized-array-vocab-not-loaded ] ?if-old ; foldable
M: pointer c-array-type? drop void* c-array-type? ;
meta-d clone #return, ;
: required-stack-effect ( word -- effect )
- dup stack-effect [ ] [ missing-effect ] ?if ;
+ dup stack-effect [ ] [ missing-effect ] ?if-old ;
: with-infer ( quot -- effect visitor )
[
] if ;
: chop-; ( seq -- seq' )
- { ";" } split1-last [ ] [ ] ?if ;
+ { ";" } split1-last [ ] [ ] ?if-old ;
: complete-vocab-list? ( tokens -- ? )
chop-; 1 index-or-length head* "USING:" swap member? ;
: copy-library ( dir library -- )
dup find-library*
[ tuck file-name append-path copy-file ]
- [ can't-deploy-library-file ] ?if ;
+ [ can't-deploy-library-file ] ?if-old ;
: copy-libraries ( manifest name dir -- )
append-path swap libraries>> [ copy-library ] with each ;
: key-code ( event -- string ? )
dup -> keyCode key-codes at
- [ t ] [ -> charactersIgnoringModifiers CF>string f ] ?if ;
+ [ t ] [ -> charactersIgnoringModifiers CF>string f ] ?if-old ;
: event-modifiers ( event -- modifiers )
-> modifierFlags modifiers modifier ;
: pick-up ( point gadget -- child/f )
2dup [ dup point>rect ] dip children-on
[ contains-point? ] with find-last nip
- [ [ loc>> v- ] [ pick-up ] bi ] [ nip ] ?if ;
+ [ [ loc>> v- ] [ pick-up ] bi ] [ nip ] ?if-old ;
: max-dims ( seq -- dim )
[ 0 0 ] dip [ first2 swapd [ max ] 2bi@ ] each 2array ;
2dup (make-pixel-format)
[ pixel-format new-disposable swap >>handle swap >>world ]
[ invalid-pixel-format-attributes ]
- ?if ;
+ ?if-old ;
M: pixel-format dispose*
[ (free-pixel-format) ] [ f >>handle drop ] bi ;
M: interactor stream-read-quot
dup interactor-yield dup array? [
over interactor-finish try-parse
- [ ] [ stream-read-quot ] ?if
+ [ ] [ stream-read-quot ] ?if-old
] [ nip ] if ;
: interactor-operation ( gesture interactor -- ? )
string [
dup special-case
[ string-quot call out push-all ]
- [ char-quot call out push ] ?if
+ [ char-quot call out push ] ?if-old
] each out "" like ; inline
: locale>lower ( string -- string' )
[ drop 26 ] [
0xE0100 0xE01EF between? 5 29 ?
] if
- ] ?if ; inline
+ ] ?if-old ; inline
: category ( char -- category )
category-num categories nth ;
: (chain-decomposed) ( hash value -- newvalue )
[
2dup of
- [ (chain-decomposed) ] [ 1array nip ] ?if
+ [ (chain-decomposed) ] [ 1array nip ] ?if-old
] with map concat ;
: chain-decomposed ( hash -- newhash )
! These numbers come from UAX 29
: initial? ( ch -- ? )
- dup 0x1100 0x1159 ?between? [ ] [ 0x115F = ] ?if ; inline
+ dup 0x1100 0x1159 ?between? [ ] [ 0x115F = ] ?if-old ; inline
: medial? ( ch -- ? ) 0x1160 0x11A2 ?between? ; inline
: final? ( ch -- ? ) 0x11A8 0x11F9 ?between? ; inline
string [
>fixnum dup ascii? [ out push ] [
dup hangul? [ hangul>jamo out push-all ]
- [ dup quot call [ out push-all ] [ out push ] ?if ] if
+ [ dup quot call [ out push-all ] [ out push ] ?if-old ] if
] if
] each
out "" like dup reorder ; inline
[ _ with-current-vocab ] [ ] [ forget-vocab ] cleanup
] with-compilation-unit
] keep
- ] ?if ; inline
+ ] ?if-old ; inline
dupd vocab-file-path [
swap [ ?delete-file ] [ swap utf8 set-file-lines ] if-empty
\ vocab-file-lines reset-memoized
- ] [ vocab-name no-vocab ] ?if ;
+ ] [ vocab-name no-vocab ] ?if-old ;
: vocab-resources-path ( vocab -- path/f )
"resources.txt" vocab-file-path ;
] if
] [
file-exists?
- ] ??if ;
+ ] ?if ;
SYMBOL: changed-vocabs
: escape-string-by ( str table -- escaped )
! Convert <, >, &, ' and " to HTML entities.
- [ '[ [ _ at ] [ % ] [ , ] ??if ] each ] "" make ;
+ [ '[ [ _ at ] [ % ] [ , ] ?if ] each ] "" make ;
: escape-string ( str -- newstr )
entities-out escape-string-by ;
] [ drop f ] if* ;
: interpret-name ( str -- name )
- dup prefixed-name [ ] [ <simple-name> ] ?if ;
+ dup prefixed-name [ ] [ <simple-name> ] ?if-old ;
PRIVATE>
! Suddenly XML-specific
: parse-named-entity ( accum string -- )
- dup entities at [ swap push ] [
- dup extra-entities get at
+ [ entities at ]
+ [ swap push ]
+ [
+ [ extra-entities get at ]
[ swap push-all ] [ no-entity ] ?if
] ?if ;
: parse-pe ( accum -- )
take-; dup pe-table get at
- [ swap push-all ] [ no-entity ] ?if ;
+ [ swap push-all ] [ no-entity ] ?if-old ;
:: (parse-char) ( quot: ( ch -- ? ) accum spot -- )
spot char>> :> char
dup no-word-sep>> [ ] [
dup (keyword-map-no-word-sep) >>no-word-sep
keyword-map-no-word-sep*
- ] ?if ;
+ ] ?if-old ;
INSTANCE: keyword-map assoc
: mark-token ( -- )
current-keyword
- dup mark-number [ ] [ mark-keyword ] ?if
+ [ mark-number ] [ mark-keyword ] ?unless
[ prev-token, ] when* ;
: current-char ( -- char )
in-rule-set>> escape-rule>> [ ] [
parent>> in-rule-set>>
dup [ escape-rule>> ] when
- ] ?if ;
+ ] ?if-old ;
: check-escape-rule ( rule -- ? )
escape-rule>> [ find-escape-rule ] unless*
: init-token-marker ( main prev-context line -- )
line set
- [ ] [ f <line-context> ] ?if context set
+ [ ] [ f <line-context> ] ?if-old context set
0 position set
0 last-offset set
0 whitespace-end set
M: tuple hashcode* [ tuple-hashcode ] recursive-hashcode ;
M: tuple-class new
- dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if ;
+ dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if-old ;
M: tuple-class boa
[ "boa-check" word-prop [ call ] when* ]
"Forms abstracting a common stack shuffle pattern:"
{ $subsections if* when* unless* }
"Another form abstracting a common stack shuffle pattern:"
-{ $subsections ?if }
+{ $subsections ?if-old }
"Sometimes instead of branching, you just need to pick one of two values:"
{ $subsections ? }
"Two combinators which abstract out nested chains of " { $link if } ":"
PRIVATE>
: ifcc ( capture restore -- )
- [ dummy-1 current-continuation ] 2dip [ dummy-2 ] prepose ?if ; inline
+ [ dummy-1 current-continuation ] 2dip [ dummy-2 ] prepose ?if-old ; inline
: callcc0 ( quot -- ) [ drop ] ifcc ; inline
ERROR: no-next-method method ;
: (call-next-method) ( method -- )
- dup next-method-quot [ call ] [ no-next-method ] ?if ;
+ dup next-method-quot [ call ] [ no-next-method ] ?if-old ;
ERROR: check-method-error class generic ;
: (math-method) ( generic class -- quot )
over ?lookup-method
[ 1quotation ]
- [ default-math-method ] ?if ;
+ [ default-math-method ] ?if-old ;
PRIVATE>
: push-method ( method class atomic assoc -- )
dupd [
- [ ] [ H{ } clone <predicate-engine> ] ?if
+ [ ] [ H{ } clone <predicate-engine> ] ?if-old
[ methods>> set-at ] keep
] change-at ;
"The following two lines are equivalent:"
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
-HELP: ?if
+HELP: ?if-old
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation ( ..a cond -- ..b ) } } { "false" { $quotation ( ..a default -- ..b ) } } }
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." }
{ $notes
{ 0 } [ f [ 0 ] unless* ] unit-test
{ t } [ t [ "Hello" ] unless* ] unit-test
-{ "2\n" } [ [ 1 2 [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
-{ "9\n" } [ [ 3 f [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
+{ "2\n" } [ [ 1 2 [ . ] [ sq . ] ?if-old ] with-string-writer ] unit-test
+{ "9\n" } [ [ 3 f [ . ] [ sq . ] ?if-old ] with-string-writer ] unit-test
{ f } [ f (clone) ] unit-test
{ -123 } [ -123 (clone) ] unit-test
: ?transmute ( obj/f quot -- obj' ) dupd when ; inline
! Default
-: ?if ( ..a obj cond true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
+
+: ?if-old ( ..a obj cond true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
: ?when ( ..a obj cond: ( ..a obj -- obj/f ) true: ( ..a cond -- ..b ) -- ..b )
: ??if ( ..a obj cond: ( ..a obj -- obj/f ) true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
[ transmute* ] 2dip if ; inline
+: ?if ( ..a obj cond true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
+ [ transmute* ] 2dip if ; inline
+
! Dippers.
! Not declared inline because the compiler special-cases them
out>> [
packer '[
_ dup first-unsafe
- [ ] [ @ @ [ 0 rot set-nth-unsafe ] keep ] ?if
+ [ ] [ @ @ [ 0 rot set-nth-unsafe ] keep ] ?if-old
]
] keep unpacker compose ;
: private? ( word -- ? ) vocabulary>> ".private" tail? ;
: use-first-word? ( words -- ? )
- [ length 1 = ] [ ?first dup [ private? not ] [ ] ?if ] bi and
+ [ length 1 = ] [ ?first dup [ private? not ] [ ] ?if-old ] bi and
auto-use? get and ;
! True branch is a singleton public word with no name conflicts
no-word-restarted ;
: parse-word ( string -- word )
- dup search [ ] [ no-word ] ?if ;
+ dup search [ ] [ no-word ] ?if-old ;
ERROR: number-expected ;
string>number [ number-expected ] unless* ;
: parse-datum ( string -- word/number )
- dup search [ ] [
- dup string>number [ ] [ no-word ] ?if
- ] ?if ;
+ [ search ]
+ [ [ string>number ] [ no-word ] ?unless ] ?unless ;
: ?scan-datum ( -- word/number/f )
- ?scan-token dup [ parse-datum ] when ;
+ ?scan-token [ parse-datum ] ?transmute ;
: scan-datum ( -- word/number )
?scan-datum [ \ word throw-unexpected-eof ] unless* ;
M: string hashcode*
nip
dup string-hashcode
- [ ] [ dup rehash-string string-hashcode ] ?if ;
+ [ ] [ dup rehash-string string-hashcode ] ?if-old ;
M: string length
length>> ; inline
] when* require ;
: run ( vocab -- )
- [ load-vocab vocab-main ]
- [ execute( -- ) ]
+ dup load-vocab vocab-main [
+ execute( -- ) ]
[
"The " write vocab-name write
" vocabulary does not define an entry point." print
"To define one, refer to \\ MAIN: help" print
- ] ??if ;
+ ] ?if-old ;
<PRIVATE
: <rename> ( word vocab new-name -- rename )
[
2dup load-vocab words>> dupd at
- [ ] [ swap no-word-in-vocab ] ?if
+ [ ] [ swap no-word-in-vocab ] ?if-old
] dip associate rename boa ;
: add-renamed-word ( word vocab new-name -- )
GENERIC: simplify ( insn -- insn' )
-M: insn simplify [ rewrite ] [ simplify ] [ dup >avail-insn-uses ] ??if ;
+M: insn simplify [ rewrite ] [ simplify ] [ dup >avail-insn-uses ] ?if ;
M: array simplify [ simplify ] map ;
M: ##copy simplify ;
: check-redundancy ( insn -- )
dup >expr
[ exprs>vns get at ]
- [ redundant-instruction ] [ useful-instruction ] ??if ;
+ [ redundant-instruction ] [ useful-instruction ] ?if ;
M: ##phi value-number
dup inputs>> values [ vreg>vn ] map sift
: lookup-name ( name gml -- value )
dupd dictionary-stack>> assoc-stack
- [ ] [ unbound-name ] ?if ; inline
+ [ ] [ unbound-name ] ?if-old ; inline
GENERIC: exec-proc ( registers gml proc -- registers gml )
: cols ( -- n ) 0 nth-row length ;
: skip ( i seq quot -- n )
- over [ find-from drop ] dip swap [ ] [ length ] ?if ; inline
+ over [ find-from drop ] dip swap [ ] [ length ] ?if-old ; inline
: first-col ( row# -- n )
! First non-zero column
: parse-decimal ( str -- ratio )
split-decimal [ [ "0" ] when-empty ] bi@
[
- [ string>number ] [ ] [ not-an-integer ] ??if ] bi@
+ [ [ string>number ] [ not-an-integer ] ?unless ] bi@
] keep length 10^ / + swap [ neg ] when ;
SYNTAX: DECIMAL: scan-token parse-decimal suffix! ;
unclip generic? [ [ class? ] all? ] dip and ;
syntax:M: method-spec where
- dup unclip method [ ] [ first ] ?if where ;
+ dup unclip method [ ] [ first ] ?if-old where ;
syntax:M: method-spec set-where
unclip method set-where ;
f pair boa ; inline
: if-hash ( pair true-quot false-quot -- )
- [ dup hash>> ] 2dip ?if ; inline
+ [ dup hash>> ] 2dip ?if-old ; inline
M: pair assoc-size
[ assoc-size 1 + ] [ drop 1 ] if-hash ; inline
{ unless 1/4 }
{ when* 1/3 }
{ unless* 1/3 }
- { ?if 1/2 }
+ { ?if-old 1/2 }
{ cond 1/2 }
{ case 1/2 }
{ keep 1 }
[ first2 [ 1quotation ] dip [ swap 2array ] when* ] map 1quotation ;
: expected ( data name -- float )
- dupd of [ ] [ values sift sum 1 swap - ] ?if ;
+ dupd of [ ] [ values sift sum 1 swap - ] ?if-old ;
: generate ( # case-probas -- seq )
H{ } clone [
ERROR: bad-number str ;
: check-number ( str -- n )
- >string [ string>number ] [ ] [ bad-number ] ??if ;
+ >string [ string>number ] [ bad-number ] ?unless ;
EBNF: parse-smalltalk [=[
SynKeywordFactorWord factorWord_io_encodings_binary | syn keyword factorWord_io_encodings_binary contained binary binary?
SynKeywordFactorWord factorWord_io_encodings_utf8 | syn keyword factorWord_io_encodings_utf8 contained >utf8-index code-point-length code-point-offsets utf8 utf8-index> utf8?
SynKeywordFactorWord factorWord_io_files | syn keyword factorWord_io_files contained (file-appender) (file-reader) (file-writer) +input+ +output+ +retry+ <file-appender> <file-reader> <file-writer> change-file-contents change-file-lines drain file-contents file-exists? file-lines file-reader file-reader? file-writer file-writer? init-resource-path refill set-file-contents set-file-lines wait-for-fd with-file-appender with-file-reader with-file-writer
-SynKeywordFactorWord factorWord_kernel | syn keyword factorWord_kernel contained (clone) -roll -rot -rotd 2bi 2bi* 2bi@ 2curry 2dip 2drop 2dup 2keep 2keepd 2nip 2nipd 2over 2tri 2tri* 2tri@ 2with 3bi 3curry 3dip 3drop 3dup 3keep 3nip 3nipd 3tri 4dip 4drop 4dup 4keep 4nip 5drop 5nip <wrapper> = >boolean ? ?if and assert assert= assert? bi bi* bi-curry bi-curry* bi-curry@ bi@ boa boolean boolean? both? build call callstack callstack>array callstack? clear clone compose composed composed? curried curried? curry die dip do drop dup dupd either? eq? equal? execute get-callstack get-datastack get-retainstack hashcode hashcode* identity-hashcode identity-tuple identity-tuple? if if* keep keepd keepdd loop most negate new nip nipd not null object or over overd pick pickd prepose reach roll rot rotd same? spin swap swapd throw tri tri* tri-curry tri-curry* tri-curry@ tri@ tuck tuple tuple? unless unless* until when when* while while* with withd wrapper wrapper? xor
+SynKeywordFactorWord factorWord_kernel | syn keyword factorWord_kernel contained (clone) -roll -rot -rotd 2bi 2bi* 2bi@ 2curry 2dip 2drop 2dup 2keep 2keepd 2nip 2nipd 2over 2tri 2tri* 2tri@ 2with 3bi 3curry 3dip 3drop 3dup 3keep 3nip 3nipd 3tri 4dip 4drop 4dup 4keep 4nip 5drop 5nip <wrapper> = >boolean ? ?when ?unless ?if ?if-old and assert assert= assert? bi bi* bi-curry bi-curry* bi-curry@ bi@ boa boolean boolean? both? build call callstack callstack>array callstack? clear clone compose composed composed? curried curried? curry die dip do drop dup dupd either? eq? equal? execute get-callstack get-datastack get-retainstack hashcode hashcode* identity-hashcode identity-tuple identity-tuple? if if* keep keepd keepdd loop most negate new nip nipd not null object or over overd pick pickd prepose reach roll rot rotd same? spin swap swapd throw tri tri* tri-curry tri-curry* tri-curry@ tri@ tuck tuple tuple? unless unless* until when when* while while* with withd wrapper wrapper? xor
SynKeywordFactorWord factorWord_layouts | syn keyword factorWord_layouts contained (first-bignum) (fixnum-bits) (max-array-capacity) 32-bit? 64-bit? bootstrap-cell bootstrap-cell-bits bootstrap-cells bootstrap-first-bignum bootstrap-fixnum-bits bootstrap-max-array-capacity bootstrap-most-negative-fixnum bootstrap-most-positive-fixnum cell cell-bits cells data-alignment first-bignum fixnum-bits hashcode-shift header-bits immediate immediate? leaf-stack-frame-size max-array-capacity mega-cache-size most-negative-fixnum most-positive-fixnum num-types tag-bits tag-fixnum tag-header tag-mask type-number type-numbers untag-fixnum
SynKeywordFactorWord factorWord_make | syn keyword factorWord_make contained % %% , ,+ ,, building make
SynKeywordFactorWord factorWord_math | syn keyword factorWord_math contained * + - / /f /i /mod 2/ 2^ < <= <fp-nan> > >= >bignum >fixnum >float >fraction >integer >rect ?1+ abs align all-integers-from? all-integers? bignum bignum? bit? bitand bitnot bitor bits>double bits>float bitxor complex complex? denominator double>bits each-integer each-integer-from even? find-integer find-integer-from find-last-integer fixnum fixnum? float float>bits float? fp-bitwise= fp-infinity? fp-nan-payload fp-nan? fp-qnan? fp-sign fp-snan? fp-special? gcd if-zero imaginary-part integer integer>fixnum integer>fixnum-strict integer? log2 log2-expects-positive log2-expects-positive? mod neg neg? next-float next-power-of-2 number number= number? numerator odd? power-of-2? prev-float ratio ratio? rational rational? real real-part real? recip rect> recursive-hashcode rem sgn shift simple-gcd sq times u< u<= u> u>= unless-zero unordered? until-zero when-zero zero?
projects / factor.git / commitdiff