: ?pasteboard-string ( pboard error -- str/f )
over pasteboard-string? [
- swap pasteboard-string [ ] [ pasteboard-error ] ?if-old
+ swap pasteboard-string or* [ pasteboard-error ] unless
] [
nip pasteboard-error
] if ;
[ predicate-output-infos 1array ] 2bi ;
: default-output-value-infos ( #call word -- infos )
- "default-output-classes" word-prop
- [ class-infos ] [ out-d>> length object-info <repetition> ] ?if-old ;
+ "default-output-classes" word-prop or*
+ [ class-infos ] [ out-d>> length object-info <repetition> ] if ;
: output-value-infos ( #call word -- infos )
{
} case ;
M: ppc.32 %load-memory-imm
- [
+ or* [
pick %trap-null
{
{ c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
{ float-rep [ LFS ] }
{ double-rep [ LFD ] }
} case
- ] ?if-old ;
+ ] if ;
M: ppc.64 %load-memory-imm
- [
+ or* [
pick %trap-null
{
{ c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
{ float-rep [ [ scratch-reg ] dip LI scratch-reg LFSX ] }
{ double-rep [ [ scratch-reg ] dip LI scratch-reg LFDX ] }
} case
- ] ?if-old ;
+ ] if ;
M: ppc.32 %load-memory
[ [ 0 assert= ] bi@ ] 2dip
- [
+ or* [
pick %trap-null
{
{ c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
{ float-rep [ LFSX ] }
{ double-rep [ LFDX ] }
} case
- ] ?if-old ;
+ ] if ;
M: ppc.64 %load-memory
[ [ 0 assert= ] bi@ ] 2dip
- [
+ or* [
pick %trap-null
{
{ c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
{ float-rep [ LFSX ] }
{ double-rep [ LFDX ] }
} case
- ] ?if-old ;
+ ] if ;
M: ppc.32 %store-memory-imm
- [
+ or* [
{
{ c:char [ STB ] }
{ c:uchar [ STB ] }
{ float-rep [ STFS ] }
{ double-rep [ STFD ] }
} case
- ] ?if-old ;
+ ] if ;
M: ppc.64 %store-memory-imm
- [
+ or* [
{
{ c:char [ STB ] }
{ c:uchar [ STB ] }
{ float-rep [ [ scratch-reg ] dip LI scratch-reg STFSX ] }
{ double-rep [ [ scratch-reg ] dip LI scratch-reg STFDX ] }
} case
- ] ?if-old ;
+ ] if ;
M: ppc.32 %store-memory
[ [ 0 assert= ] bi@ ] 2dip
- [
+ or* [
{
{ c:char [ STBX ] }
{ c:uchar [ STBX ] }
{ float-rep [ STFSX ] }
{ double-rep [ STFDX ] }
} case
- ] ?if-old ;
+ ] if ;
M: ppc.64 %store-memory
[ [ 0 assert= ] bi@ ] 2dip
- [
+ or* [
{
{ c:char [ STBX ] }
{ c:uchar [ STBX ] }
{ float-rep [ STFSX ] }
{ double-rep [ STFDX ] }
} case
- ] ?if-old ;
+ ] if ;
M:: ppc %allot ( dst size class nursery-ptr -- )
! dst = vm->nursery.here;
[ [ drop 1array ] [ [+] ] 2bi ] 2dip ;
: (%load-memory) ( dst exclude address rep c-type -- )
- [
+ or* [
{
{ c:char [ 8 %alien-signed-getter ] }
{ c:uchar [ 8 %alien-unsigned-getter ] }
{ c:int [ 32 %alien-signed-getter ] }
{ c:uint [ 32 [ 2drop ] %alien-integer-getter ] }
} case
- ] [ nipd %copy ] ?if-old ;
+ ] [ nipd %copy ] if ;
M: x86 %load-memory
(%memory) (%load-memory) ;
(%memory-imm) (%load-memory) ;
: (%store-memory) ( src exclude address rep c-type -- )
- [
+ or* [
{
{ c:char [ 8 %alien-integer-setter ] }
{ c:uchar [ 8 %alien-integer-setter ] }
{ c:int [ 32 %alien-integer-setter ] }
{ c:uint [ 32 %alien-integer-setter ] }
} case
- ] [ [ nip swap ] dip %copy ] ?if-old ;
+ ] [ [ nip swap ] dip %copy ] if ;
M: x86 %store-memory
(%memory) (%store-memory) ;
XML-NS: chloe-name http://factorcode.org/chloe/1.0
: required-attr ( tag name -- value )
- [ nip ] [ chloe-name attr ] 2bi
- [ ] [ " attribute is required" append throw ] ?if-old ;
+ [ nip ] [ chloe-name attr ] 2bi or*
+ [ " attribute is required" append throw ] unless ;
: optional-attr ( tag name -- value )
chloe-name attr ;
first2
[ [ dupd match ] curry ] dip
[ with-variables ] curry rot
- [ ?if-old ] 2curry append
+ [ [ or* ] 2dip if ] 2curry append
] reduce ;
GENERIC: replace-patterns ( object -- result )
2dup shorter? [
2drop f f
] [
- 2dup length head over match
- [ swap ?rest ] [ [ rest ] dip (match-first) ] ?if-old
+ 2dup length head over match or*
+ [ swap ?rest ] [ [ rest ] dip (match-first) ] if
] if ;
: match-first ( seq pattern-seq -- bindings )
new-child
] [
[ nip ] 2keep children>> last (ppush-new-tail)
- [ swap new-child ] [ swap node-set-last f ] ?if-old
+ or* [ swap new-child ] [ swap node-set-last f ] if
] if ;
: do-expansion ( pvec root expansion/f -- pvec )
}
: key-code ( event -- string ? )
- dup -> keyCode key-codes at
- [ t ] [ -> charactersIgnoringModifiers CF>string f ] ?if-old ;
+ dup -> keyCode key-codes at or*
+ [ t ] [ -> charactersIgnoringModifiers CF>string f ] if ;
: 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-old ;
+ or* [ [ loc>> v- ] [ pick-up ] bi ] [ nip ] if ;
: max-dims ( seq -- dim )
[ 0 0 ] dip [ first2 swapd [ max ] 2bi@ ] each 2array ;
TUPLE: pixel-format < disposable world handle ;
: <pixel-format> ( world attributes -- pixel-format )
- 2dup (make-pixel-format)
+ 2dup (make-pixel-format) or*
[ pixel-format new-disposable swap >>handle swap >>world ]
[ invalid-pixel-format-attributes ]
- ?if-old ;
+ if ;
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-old
+ or* [ stream-read-quot ] unless
] [ nip ] if ;
: interactor-operation ( gesture interactor -- ? )
: (chain-decomposed) ( hash value -- newvalue )
[
- 2dup of
- [ (chain-decomposed) ] [ 1array nip ] ?if-old
+ 2dup of or*
+ [ (chain-decomposed) ] [ 1array nip ] if
] with map concat ;
: chain-decomposed ( hash -- newhash )
string [
>fixnum dup ascii? [ out push ] [
dup hangul? [ hangul>jamo out push-all ]
- [ dup quot call [ out push-all ] [ out push ] ?if-old ] if
+ [ dup quot call or* [ out push-all ] [ out push ] if ] if
] if
] each
out "" like dup reorder ; inline
[ _ with-current-vocab ] [ ] [ forget-vocab ] cleanup
] with-compilation-unit
] keep
- ] ?if-old ; inline
+ ] [ or* ] 2dip if ; inline
] when ;
: set-vocab-file-lines ( lines vocab name -- )
- dupd vocab-file-path [
+ dupd vocab-file-path or* [
swap [ ?delete-file ] [ swap utf8 set-file-lines ] if-empty
\ vocab-file-lines reset-memoized
- ] [ vocab-name no-vocab ] ?if-old ;
+ ] [ vocab-name no-vocab ] if ;
: vocab-resources-path ( vocab -- path/f )
"resources.txt" vocab-file-path ;
f >>in-rule context set ;
: init-token-marker ( main prev-context line -- )
- line set
- [ ] [ f <line-context> ] ?if-old context set
+ line set or* [ f <line-context> ] unless context set
0 position set
0 last-offset set
0 whitespace-end set
"Forms abstracting a common stack shuffle pattern:"
{ $subsections if* when* unless* }
"Another form abstracting a common stack shuffle pattern:"
-{ $subsections ?if-old }
+{ $subsections ?if }
"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-old ; inline
+ [ dummy-1 current-continuation or* ] 2dip [ dummy-2 ] prepose if ; inline
: callcc0 ( quot -- ) [ drop ] ifcc ; inline
<PRIVATE
: (math-method) ( generic class -- quot )
- over ?lookup-method
+ over ?lookup-method or*
[ 1quotation ]
- [ default-math-method ] ?if-old ;
+ [ default-math-method ] if ;
PRIVATE>
: push-method ( method class atomic assoc -- )
dupd [
- [ ] [ H{ } clone <predicate-engine> ] ?if-old
+ or* [ H{ } clone <predicate-engine> ] unless
[ methods>> set-at ] keep
] change-at ;
"The following two lines are equivalent:"
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
-HELP: ?if-old
-{ $values { "obj" 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
-"The following two lines are equivalent:"
-{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" }
-"The following two lines are equivalent:"
-{ $code "[ ] [ ] ?if" "swap or" } } ;
-
HELP: die
{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." }
{ $notes
{ 0 } [ f [ 0 ] unless* ] unit-test
{ t } [ t [ "Hello" ] unless* ] 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
+{ "2\n" } [ [ 1 2 or* [ . ] [ sq . ] if ] with-string-writer ] unit-test
+{ "9\n" } [ [ 3 f or* [ . ] [ sq . ] if ] with-string-writer ] unit-test
{ f } [ f (clone) ] unit-test
{ -123 } [ -123 (clone) ] unit-test
! Default
-: ?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 )
[ transmute* ] dip when ; inline
: or ( obj1 obj2 -- ? ) dupd ? ; inline
+: or* ( obj1 obj2 -- obj2/obj1 second? ) [ nip t ] [ f ] if* ; inline
+
: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline
: both? ( x y quot -- ? ) bi@ and ; inline
: private? ( word -- ? ) vocabulary>> ".private" tail? ;
: use-first-word? ( words -- ? )
- [ length 1 = ] [ ?first dup [ private? not ] [ ] ?if-old ] bi and
+ [ length 1 = ] [ ?first dup or* [ private? not ] unless ] bi and
auto-use? get and ;
! True branch is a singleton public word with no name conflicts
: <rename> ( word vocab new-name -- rename )
[
2dup load-vocab words>> dupd at
- [ ] [ swap no-word-in-vocab ] ?if-old
+ or* [ swap no-word-in-vocab ] unless
] dip associate rename boa ;
: add-renamed-word ( word vocab new-name -- )
: lookup-name ( name gml -- value )
dupd dictionary-stack>> assoc-stack
- [ ] [ unbound-name ] ?if-old ; inline
+ or* [ unbound-name ] unless ; 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-old ; inline
+ over [ find-from drop ] dip swap or* [ length ] unless ; inline
: first-col ( row# -- n )
! First non-zero column
unclip generic? [ [ class? ] all? ] dip and ;
syntax:M: method-spec where
- dup unclip method [ ] [ first ] ?if-old where ;
+ dup unclip method or* [ first ] unless 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-old ; inline
+ [ hash>> ] -rot ?if ; inline
M: pair assoc-size
[ assoc-size 1 + ] [ drop 1 ] if-hash ; inline
{ unless 1/4 }
{ when* 1/3 }
{ unless* 1/3 }
- { ?if-old 1/2 }
+ { ?if 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-old ;
+ dupd of or* [ values sift sum 1 swap - ] unless ;
: generate ( # case-probas -- seq )
H{ } clone [
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 ? ?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_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 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 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