c-type-word pointer ;
: resolve-typedef ( name -- c-type )
- dup void? [ no-c-type ] when
+ [ void? ] [ no-c-type ] ?when
dup c-type-name? [ lookup-c-type ] when ;
M: word lookup-c-type
- dup "c-type" word-prop resolve-typedef
- [ ] [ no-c-type ] ?if ;
+ [ "c-type" word-prop resolve-typedef ]
+ [ no-c-type ] ?unless ;
GENERIC: c-type-class ( name -- class )
! try to open a library that is the first name in that list anyway
! or "library_not_found" as a last resort for better debugging.
: find-library-from-list ( seq -- path/f )
- dup [ find-library* ] map-find drop
- [ ] [ ?first "library_not_found" or ] ?if ;
+ [ [ find-library* ] map-find drop ]
+ [ ?first "library_not_found" or ] ?unless ;
"alien.libraries.finder." os name>> append require
{ [ use-dyld-shared-cache? ] [ _dyld_shared_cache_contains_path ] }
[ drop f ]
} cond
- ] find [ nip ] when* ;
+ ] find nip ;
: framework-find ( name -- path )
dup dyld-find [ nip ] [
[ target-word ] keep or ;
: fixup-word ( word -- offset )
- transfer-word dup lookup-object
- [ ] [ [ vocabulary>> ] [ name>> ] bi not-in-image ] ?if ;
+ transfer-word
+ [ lookup-object ] [ [ vocabulary>> ] [ name>> ] bi not-in-image ] ?unless ;
: fixup-words ( -- )
bootstrapping-image get [ dup word? [ fixup-word ] when ] map! drop ;
ERROR: tuple-removed class ;
: require-tuple-layout ( word -- layout )
- dup tuple-layout [ ] [ tuple-removed ] ?if ;
+ [ tuple-layout ] [ tuple-removed ] ?unless ;
: (emit-tuple) ( tuple -- pointer )
[ tuple-slots ]
handle>> evp-md-ctx-free ;
: digest-named ( name -- md )
- dup EVP_get_digestbyname [ ] [ unknown-digest ] ?if ;
+ [ EVP_get_digestbyname ] [ unknown-digest ] ?unless ;
: set-digest ( name ctx -- )
handle>> swap digest-named f EVP_DigestInit_ex ssl-error ;
<PRIVATE
: init-struct ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
- '[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
+ '[ [ struct-prototype ] _ _ ??if ] keep memory>struct ; inline
PRIVATE>
objc-methods get at ;
: lookup-objc-method ( name -- signature )
- dup ?lookup-objc-method [ ] [ no-objc-method ] ?if ;
+ [ ?lookup-objc-method ] [ no-objc-method ] ?unless ;
MEMO: make-prepare-send ( selector signature super? -- quot )
[
ERROR: no-objc-type name ;
: decode-type ( ch -- ctype )
- 1string dup objc>alien-types get at
- [ ] [ no-objc-type ] ?if ;
+ 1string
+ [ objc>alien-types get at ] [ no-objc-type ] ?unless ;
: (parse-objc-type) ( i string -- ctype )
[ [ 1 + ] dip ] [ nth ] 2bi {
] [ drop ] if ;
: root-class ( class -- root )
- dup class_getSuperclass [ root-class ] [ ] ?if ;
+ [ class_getSuperclass ] [ root-class ] ?when ;
: objc-class-names ( -- seq )
[
: pasteboard-string ( pasteboard -- str )
NSStringPboardType <NSString> -> stringForType:
- dup [ CF>string ] when ;
+ [ CF>string ] transmute ;
: set-pasteboard-types ( seq pasteboard -- )
swap <CFArray> -> autorelease f -> declareTypes:owner: drop ;
tri ;
: encode-type ( type -- encoded )
- dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;
+ [ alien>objc-types get at ] [ no-objc-type ] ?unless ;
: encode-types ( return types -- encoding )
swap prefix [ encode-type "0" append ] map concat ;
ERROR: no-such-color name ;
: named-color ( name -- color )
- dup colors at [ ] [ no-such-color ] ?if ;
+ [ colors at ] [ no-such-color ] ?unless ;
: parse-color ( str -- color )
"#" ?head [ hex>rgba ] [ named-color ] if ;
[ [ cc= ^^compare-integer ] binary-op ] [ [ cc= ^^compare ] binary-op ] if ;
: emit-special-object ( block node -- block' )
- dup node-input-infos first literal>> [
+ [ node-input-infos first literal>> ] [
ds-drop
vm-special-object-offset ^^vm-field
ds-push
- ] [ emit-primitive ] ?if ;
+ ] [ emit-primitive ] ??if ;
: emit-set-special-object ( block node -- block' )
- dup node-input-infos second literal>> [
+ [ node-input-infos second literal>> ] [
ds-drop
[ ds-pop ] dip vm-special-object-offset ##set-vm-field,
- ] [ emit-primitive ] ?if ;
+ ] [ emit-primitive ] ??if ;
: context-object-offset ( n -- n )
cells "context-objects" context offset-of + ;
: emit-context-object ( block node -- block' )
- dup node-input-infos first literal>> [
+ [ 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 ;
: emit-identity-hashcode ( -- )
[
[ needs-loops ]
[ needs-predecessors ]
[
- dup linear-order>> [ ] [
+ [ linear-order>> ] [
dup (linearization-order)
>>linear-order linear-order>>
- ] ?if
+ ] ?unless
]
} cleave ;
[ >>number drop ] 2each ;
: post-order ( cfg -- blocks )
- dup post-order>> [ ] [
+ [ post-order>> ] [
[
HS{ } clone over entry>>
post-order-traversal drop
] { } make dup number-blocks
>>post-order post-order>>
- ] ?if ;
+ ] ?unless ;
: reverse-post-order ( cfg -- blocks )
post-order <reversed> ; inline
: peek-loc ( loc -- vreg )
height-state get global-loc>local
- dup replaces get at
- [ ] [ dup local-peek-set get adjoin loc>vreg ] ?if ;
+ [ replaces get at ]
+ [ dup local-peek-set get adjoin loc>vreg ] ?unless ;
: replace-loc ( vreg loc -- )
height-state get global-loc>local replaces get set-at ;
insn ;
: check-redundancy ( insn -- insn' )
- dup >expr dup exprs>vns get at
- [ redundant-instruction ] [ useful-instruction ] ?if ;
+ dup >expr
+ [ exprs>vns get at ]
+ [ redundant-instruction ] [ useful-instruction ] ??if ;
M: insn process-instruction
- dup rewrite [ process-instruction ] [ ] ?if ;
+ [ rewrite ] [ process-instruction ] ?when ;
M: foldable-insn process-instruction
- dup rewrite
+ [ rewrite ]
[ process-instruction ]
- [ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if ;
+ [ dup defs-vregs length 1 = [ check-redundancy ] when ] ??if ;
M: ##copy process-instruction
dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
{
[ dup { [ in-r>> empty? ] [ out-r>> empty? ] } 1&& ]
[
- shuffle-effect dup pretty-shuffle
- [ % ] [ shuffle-node boa , ] ?if
+ shuffle-effect
+ [ pretty-shuffle ] [ % ] [ shuffle-node boa , ] ??if
]
}
[ drop "COMPLEX SHUFFLE" , ]
: (flatten-values) ( values accum -- )
dup '[
- dup unboxed-allocation
- [ _ (flatten-values) ] [ _ push ] ?if
+ [ unboxed-allocation ]
+ [ _ (flatten-values) ] [ _ push ] ??if
] each ;
: flatten-values ( values -- values' )
registered-remote-threads delete-at ;
: get-remote-thread ( name -- thread )
- dup registered-remote-threads at [ ] [ threads at ] ?if ;
+ [ registered-remote-threads at ] [ threads at ] ?unless ;
SYMBOL: local-node
GENERIC: mailbox-of ( thread -- mailbox )
M: thread mailbox-of
- dup mailbox>>
+ [ mailbox>> ]
[ { mailbox } declare ]
- [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
+ [ <mailbox> [ >>mailbox drop ] keep ] ??if ; inline
M: thread send
mailbox-of mailbox-put ;
] keep CFRelease ;
: load-framework ( name -- )
- dup <CFBundle> [
- CFBundleLoadExecutable drop
- ] [
- "Cannot load bundle named " prepend throw
- ] ?if ;
+ [ <CFBundle> ]
+ [ CFBundleLoadExecutable drop ]
+ [ "Cannot load bundle named " prepend throw ] ??if ;
ERROR: not-persistent class ;
: db-table-name ( class -- object )
- dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
+ [ "db-table" word-prop ] [ not-persistent ] ?unless ;
: db-columns ( class -- object )
superclasses-of [ "db-columns" word-prop ] map concat ;
GENERIC: edit ( object -- )
M: object edit
- dup where [ first2 edit-location ] [ cannot-find-source ] ?if ;
+ [ where ] [ first2 edit-location ] [ cannot-find-source ] ??if ;
M: string edit edit-vocab ;
{ "random-integers" { "randoms" "0.99" } }
{ "count*" { "percent-of" "0.99" } }
{ "more?" { "deref?" "0.99" } }
+ { "plox" { "?transmute" "0.99" } }
}
: compute-assoc-fixups ( continuation name assoc -- seq )
} case ;
: end-aside ( default -- response )
- aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
+ [ drop aside-id get aside-id off get-aside ]
+ [ move-on ] [ <redirect> ] ??if ;
M: asides link-attr
drop
[ drop first CHAR: _ = ] assoc-reject ;
: at-or-k ( key hash -- newkey )
- dupd at [ nip ] when* ;
+ ?at drop ;
: value-at-or-k ( key hash -- newkey )
- dupd value-at [ nip ] when* ;
+ ?value-at drop ;
: map-fields-forward ( assoc field-map -- assoc )
[ swapd at-or-k swap ] curry assoc-map ;
ERROR: unknown-type-error type ;
: get-type-info ( data-type -- info )
- qualified-type-name dup type-infos get-global at
- [ ] [ unknown-type-error ] ?if ;
+ qualified-type-name
+ [ type-infos get-global at ]
+ [ unknown-type-error ] ?unless ;
: find-type-info ( data-type -- info/f )
qualified-type-name type-infos get-global at ;
PRIVATE>
: word-help ( word -- content )
- [ dup "help" word-prop [ ] [ word-help* ] ?if ] keep
+ [ [ "help" word-prop ] [ word-help* ] ?unless ] keep
inputs-and-outputs fix-shuffle drop ;
: effect-help ( effect -- content )
[xml-code] ;
CHLOE: style
- dup "include" optional-attr [
- utf8 file-contents [ add-style ] [code-with]
- ] [
- compile-children>string [ add-style ] [code]
- ] ?if ;
+ [ "include" optional-attr ]
+ [ utf8 file-contents [ add-style ] [code-with] ]
+ [ compile-children>string [ add-style ] [code] ] ??if ;
CHLOE: write-style
drop [
] [xml-code] ;
CHLOE: script
- dup "include" optional-attr [
- utf8 file-contents [ add-script ] [code-with]
- ] [
- compile-children>string [ add-script ] [code]
- ] ?if ;
+ [ "include" optional-attr ]
+ [ utf8 file-contents [ add-script ] [code-with] ]
+ [ compile-children>string [ add-script ] [code] ] ??if ;
CHLOE: write-script
drop [
] when ;
: template-quot ( chloe -- quot )
- dup cached-template [ ] [
+ [ cached-template ] [
[ load-template dup ] keep
template-cache get set-at
- ] ?if quot>> ;
+ ] ?unless quot>> ;
: reset-cache ( -- )
template-cache get clear-assoc ;
ERROR: unknown-chloe-tag tag ;
: compile-chloe-tag ( tag -- )
- dup main>> dup chloe-tags get at
+ dup main>>
+ [ chloe-tags get at ]
[ call( tag -- ) ]
[ unknown-chloe-tag ]
- ?if ;
+ ??if ;
: compile-string ( string -- )
string-context? get [ escape-string ] unless [write] ;
M: gadget baseline drop f ;
M: aligned-gadget baseline
- dup baseline>>
- [ ] [
+ [ baseline>> ] [
[ baseline* ] [ ] [ layout-state>> ] tri
[ drop ] [ dupd baseline<< ] if
- ] ?if ;
+ ] ?unless ;
GENERIC: cap-height* ( gadget -- y )
M: gadget cap-height drop f ;
M: aligned-gadget cap-height
- dup cap-height>>
- [ ] [
+ [ cap-height>> ] [
[ cap-height* ] [ ] [ layout-state>> ] tri
[ drop ] [ dupd cap-height<< ] if
- ] ?if ;
+ ] ?unless ;
<PRIVATE
{ } like command-map boa ;
: commands ( class -- hash )
- dup "commands" word-prop [ ] [
+ [ "commands" word-prop ] [
H{ } clone [ "commands" set-word-prop ] keep
- ] ?if ;
+ ] ?unless ;
TR: convert-command-name "-" " " ;
GENERIC: pref-dim* ( gadget -- dim )
: pref-dim ( gadget -- dim )
- dup pref-dim>> [ ] [
+ [ pref-dim>> ] [
[ pref-dim* ] [ ] [ layout-state>> ] tri
[ drop ] [ dupd pref-dim<< ] if
- ] ?if ;
+ ] ?unless ;
: pref-dims ( gadgets -- seq ) [ pref-dim ] map ; inline
GENERIC: line-leading ( gadget -- n )
M: line-gadget line-leading
- dup line-leading>>
- [ ] [
+ [ line-leading>> ]
+ [
[ line-leading* ] [ ] [ layout-state>> ] tri
[ drop ] [ dupd line-leading<< ] if
- ] ?if ;
+ ] ?unless ;
GENERIC: line-height* ( gadget -- n )
GENERIC: line-height ( gadget -- n )
M: line-gadget line-height
- dup line-height>>
- [ ] [
+ [ line-height>> ]
+ [
[ line-height* ] [ ] [ layout-state>> ] tri
[ drop ] [ dupd line-height<< ] if
- ] ?if ;
+ ] ?unless ;
: y>line ( y gadget -- n ) line-height /i ;
[ pref-dim ] [ line-gadget-dim ] bi ;
M: line-gadget pref-viewport-dim
- dup pref-viewport-dim>>
- [ ] [
+ [ pref-viewport-dim>> ]
+ [
[ pref-viewport-dim* ] [ ] [ layout-state>> ] tri
[ drop ] [ dupd pref-viewport-dim<< ] if
- ] ?if ;
+ ] ?unless ;
M: line-gadget pref-dim* { 0 0 } swap line-gadget-dim ;
wrap-words [ <line> ] map! ;
: cached-wrapped ( paragraph -- wrapped-paragraph )
- dup wrapped>>
- [ ] [ [ wrap-paragraph dup ] keep wrapped<< ] ?if ;
+ [ wrapped>> ]
+ [ [ wrap-paragraph dup ] keep wrapped<< ] ?unless ;
: max-line-width ( wrapped-paragraph -- x )
[ width>> ] [ max ] map-reduce ;
] dip translate-column ;
: table-column-alignment ( table -- seq )
- dup renderer>> column-alignment
- [ ] [ column-widths>> length 0 <repetition> ] ?if ;
+ [ renderer>> column-alignment ]
+ [ column-widths>> length 0 <repetition> ] ?unless ;
:: row-font ( row index table -- font )
table font>> clone
TUPLE: propagate-key-gesture-tuple gesture world ;
: world-focus ( world -- gadget )
- dup focus>> [ world-focus ] [ ] ?if ;
+ [ focus>> ] [ world-focus ] ?when ;
M: propagate-key-gesture-tuple send-queued-gesture
[ gesture>> ] [ world>> world-focus ] bi
dup primary-operation invoke-command ;
: secondary-operation ( obj -- operation )
- dup
- [ command>> +secondary+ word-prop ] find-operation
- [ ] [ primary-operation ] ?if ;
+ [ [ command>> +secondary+ word-prop ] find-operation ]
+ [ primary-operation ] ?unless ;
: invoke-secondary-operation ( obj -- )
dup secondary-operation invoke-command ;
utf8 file-lines parse-colors ;
: named-base16 ( name -- color )
- dup base16-theme-name get base16colors at [ ] [ no-such-color ] ?if ;
+ [ base16-theme-name get base16colors at ] [ no-such-color ] ?unless ;
SINGLETON: base16-theme
PRIVATE>
: group-name ( id -- string )
- dup group-cache get [
- ?at [ name>> ] [ number>string ] if
- ] [
- group-struct [ gr_name>> ] [ f ] if*
- ] if*
- [ ] [ number>string ] ?if ;
+ [
+ group-cache get [
+ ?at [ name>> ] [ number>string ] if
+ ] [
+ group-struct [ gr_name>> ] [ f ] if*
+ ] if*
+ ] [ number>string ] ?unless ;
: group-id ( string -- id/f )
group-struct dup [ gr_gid>> ] when ;
ERROR: malformed-port string ;
: parse-port ( string -- port/f )
- [ f ] [ dup string>number [ ] [ malformed-port ] ?if ] if-empty ;
+ [ f ] [ [ string>number ] [ malformed-port ] ?unless ] if-empty ;
: parse-host ( string -- host/f port/f )
[
] if ;
: v-number ( str -- n )
- dup string>number [ ] [ "must be a number" throw ] ?if ;
+ [ string>number ] [ "must be a number" throw ] ?unless ;
: v-integer ( str -- n )
v-number dup integer? [ "must be an integer" throw ] unless ;
: vocab-platforms ( vocab -- platforms )
"platforms.txt" vocab-file-lines
- [ dup "system" lookup-word [ ] [ bad-platform ] ?if ] map ;
+ [ [ "system" lookup-word ] [ bad-platform ] ?unless ] map ;
: supported-platform? ( platforms -- ? )
[ t ] [ [ os swap class<= ] any? ] if-empty ;
IN: vocabs.refresh
: source-modified? ( path -- ? )
- dup source-files get at [
+ [ source-files get at ]
+ [
dup path>>
dup file-exists? [
utf8 file-lines crc32 checksum-lines
] if
] [
file-exists?
- ] ?if ;
+ ] ??if ;
SYMBOL: changed-vocabs
: prolog-encoding ( prolog -- )
encoding>> dup "UTF-16" =
[ drop ] [
- dup name>encoding
- [ decode-stream ] [ bad-encoding ] ?if
+ [ name>encoding ] [ decode-stream ] [ bad-encoding ] ??if
] if ;
: instruct-encoding ( instruct/prolog -- )
: escape-string-by ( str table -- escaped )
! Convert <, >, &, ' and " to HTML entities.
- [ '[ dup _ at [ % ] [ , ] ?if ] each ] "" make ;
+ [ '[ [ _ at ] [ % ] [ , ] ??if ] each ] "" make ;
: escape-string ( str -- newstr )
entities-out escape-string-by ;
] { } make f like ;
: add-ns ( name -- )
- dup space>> dup ns-stack get assoc-stack
- [ ] [ nonexist-ns ] ?if >>url drop ;
+ dup space>>
+ [ ns-stack get assoc-stack ]
+ [ nonexist-ns ] ?unless >>url drop ;
: push-ns ( hash -- )
ns-stack get push ;
"syntax" lookup-word t "delimiter" set-word-prop ;
: define-core-syntax ( name quot -- )
- [ dup "syntax" lookup-word [ ] [ no-word-error ] ?if ] dip
+ [ [ "syntax" lookup-word ] [ no-word-error ] ?unless ] dip
define-syntax ;
[
] if ;
: vocab-exists? ( name -- ? )
- dup lookup-vocab [ ] [ find-vocab-root ] ?if ;
+ [ lookup-vocab ] [ find-vocab-root ] ?unless ;
: vocab-append-path ( vocab path -- newpath )
swap find-vocab-root [ prepend-path ] [ drop f ] if* ;
] when* require ;
: run ( vocab -- )
- dup load-vocab vocab-main [
- execute( -- )
- ] [
+ [ 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 ;
<PRIVATE
M: vocab-spec >vocab-link ;
-M: object >vocab-link dup lookup-vocab [ ] [ <vocab-link> ] ?if ;
+M: object >vocab-link [ lookup-vocab ] [ <vocab-link> ] ?unless ;
<PRIVATE
[ gensym dup ] 2dip define-declared ;
: reveal ( word -- )
- dup [ name>> ] [ vocabulary>> ] bi dup vocab-words-assoc
- [ ] [ no-vocab ] ?if set-at ;
+ dup [ name>> ] [ vocabulary>> ] bi
+ [ vocab-words-assoc ] [ no-vocab ] ?unless set-at ;
ERROR: bad-create name vocab ;
'[ name>> _ = ] find nip ;
: get-operator ( operators -- word )
- dup "Operators: %u\n" printf flush
- dup readln find-operator [ ] [
- "Operator not found..." print get-operator
- ] ?if ;
+ [ "Operators: %u\n" printf flush ]
+ [
+ [ readln find-operator ]
+ [ "Operator not found..." print get-operator ] ?unless
+ ] bi ;
: try-operator ( array -- array )
[ pprint nl ]
{ 103 203 { { 1 1 } { 2 2 } { 3 3 } } }
[ 100 200 { { 1 1 } { 2 2 } { 3 3 } } [ [ 1 + ] bi@ ] 2temp2d assoc-map ] unit-test
-
-{ 10 } [ 5 [ 2 * ] plox ] unit-test
-{ f } [ f [ 2 * ] plox ] unit-test
-
-{ 12 } [ 12 [ odd? ] [ 2/ ] plox-if ] unit-test
-{ 6 } [ 13 [ odd? ] [ 2/ ] plox-if ] unit-test
: quad@ ( w x y z quot -- ) dup dup dup quad* ; inline
-: plox ( ... x/f quot: ( ... x -- ... y ) -- ... y/f )
- dupd when ; inline
-
-: plox-if ( ... x quot: ( ... x -- ... ? ) quot: ( ... x -- ... y ) -- ... y/f )
- [ keep swap ] dip when ; inline
-
MACRO: smart-plox ( true -- quot )
[ inputs [ 1 - [ and ] n*quot ] keep ] keep swap
'[ _ _ [ _ ndrop f ] smart-if ] ;
GENERIC: simplify ( insn -- insn' )
-M: insn simplify dup 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 ;
insn vn vns>insns get set-at ;
: check-redundancy ( insn -- )
- dup >expr dup exprs>vns get at
- [ redundant-instruction ] [ useful-instruction ] ?if ;
+ dup >expr
+ [ exprs>vns get at ]
+ [ redundant-instruction ] [ useful-instruction ] ??if ;
M: ##phi value-number
dup inputs>> values [ vreg>vn ] map sift
} cond ; inline recursive
: parse-day ( str -- n )
- dup string>number [ ] [
+ [ string>number ] [
>lower $[ day-abbreviations3 [ >lower ] map ] index
- ] ?if ;
+ ] ?unless ;
: parse-month ( str -- n )
- dup string>number [ ] [
+ [ string>number ] [
>lower $[ month-abbreviations [ >lower ] map ] index
- ] ?if ;
+ ] ?unless ;
TUPLE: cronentry minutes hours days months days-of-week command ;
EC_KEY_new_by_curve_name dup ssl-error ec-key boa ;
: ec-key-handle ( -- handle )
- ec-key get dup handle>> [ ] [ already-disposed ] ?if ;
+ ec-key get [ handle>> ] [ already-disposed ] ?unless ;
DESTRUCTOR: BN_clear_free
GML: baseface ( e0 -- e1 ) base-face>> ;
-GML: nextring ( e0 -- e1 ) dup next-ring>> [ ] [ base-face>> ] ?if ;
+GML: nextring ( e0 -- e1 ) [ next-ring>> ] [ base-face>> ] ?unless ;
GML: facenormal ( e0 -- n ) face-normal ;
GML: faceplanedist ( e0 -- d ) face-plane-dist ;
{ } <struct-slot-spec> ;
: shader-filename ( shader/program -- filename )
- dup filename>> [ ] [ name>> where first ] ?if file-name ;
+ [ filename>> ] [ name>> where first ] ?unless file-name ;
: numbered-log-line? ( log-line-components -- ? )
{
}
: (word-help) ( word -- content )
- dup "help" word-prop [ ] [ word-help* ] ?if ;
+ [ "help" word-prop ] [ word-help* ] ?unless ;
GENERIC: write-object* ( object -- )
M: string write-object* write ;
: (image-gadget-texture) ( gadget -- texture )
dup image>> { 0 0 } <texture> >>texture texture>> ;
: image-gadget-texture ( gadget -- texture )
- dup texture>> [ ] [ (image-gadget-texture) ] ?if ;
+ [ texture>> ] [ (image-gadget-texture) ] ?unless ;
M: image-gadget draw-gadget* ( gadget -- )
dup image>> [
drop "Words used in infix must declare a stack effect and return exactly one value" ;
: check-word ( argcount word -- ? )
- dup stack-effect [ ] [ bad-stack-effect ] ?if
+ [ stack-effect ] [ bad-stack-effect ] ?unless
[ in>> length ] [ out>> length ] bi
[ = ] dip 1 = and ;
! ":flogbot2_!~flogbot2@c-50-174-221-28.hsd1.ca.comcast.net JOIN #concatenative-bots"
! The channel>> field is empty and it's in parameters instead.
! This fixes chat> for these kinds of messages.
-M: to-channel chat-name dup channel>> [ ] [ parameters>> ?first ] ?if ;
+M: to-channel chat-name [ channel>> ] [ parameters>> ?first ] ?unless ;
GENERIC: chat> ( obj -- chat/f )
M: string chat> irc> chats>> at ;
: parse-decimal ( str -- ratio )
split-decimal [ [ "0" ] when-empty ] bi@
[
- [ dup string>number [ ] [ not-an-integer ] ?if ] bi@
+ [ string>number ] [ ] [ not-an-integer ] ??if ] bi@
] keep length 10^ / + swap [ neg ] when ;
SYNTAX: DECIMAL: scan-token parse-decimal suffix! ;
: call-push-when ( ..a elt quot: ( ..a elt -- ..b elt' ? ) accum -- ..b )
[ call ] dip swap [ push ] [ 2drop ] if ; inline
-
-: find-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... elt i/f )
- '[ _ find-from-unsafe element/index ] bounds-check-call ; inline
-
-: find* ( ... seq quot: ( ... elt -- ... ? ) -- ... elt i/f )
- [ 0 ] 2dip find-from-unsafe element/index ; inline
-
-: find-last-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... elt i/f )
- '[ _ find-last-from-unsafe element/index ] bounds-check-call ; inline
-
-: find-last* ( ... seq quot: ( ... elt -- ... ? ) -- ... elt i/f )
- [ index-of-last ] dip find-last-from* ; inline
-
-: find-index-from* ( ... n seq quot: ( ... elt i -- ... ? ) -- ... elt i/f )
- '[
- _ [ sequence-index-operator find-integer-from ] keepd
- element/index
- ] bounds-check-call ; inline
-
-: find-index* ( ... seq quot: ( ... elt i -- ... ? ) -- ... elt i/f )
- [ 0 ] 2dip find-index-from* ; inline
spidering-site new swap >>account-name select-tuples ;
: insert-site ( url -- site )
- <site> dup select-tuple [ ] [ dup t >>up? insert-tuple ] ?if ;
+ <site> [ select-tuple ] [ dup t >>up? insert-tuple ] ?unless ;
: select-account/site ( username url -- account site )
insert-site site-id>> ;
M: ast-foreign compile-ast
nip
- [ class>> dup ":" split1 lookup-word [ ] [ no-word ] ?if ]
+ [ class>> [ ":" split1 lookup-word ] [ no-word ] ?unless ]
[ name>> ] bi define-foreign
[ nil ] ;
ERROR: bad-number str ;
: check-number ( str -- n )
- >string dup string>number [ ] [ bad-number ] ?if ;
+ >string [ string>number ] [ ] [ bad-number ] ??if ;
EBNF: parse-smalltalk [=[
M: no-such-state summary drop "No such state" ;
MEMO: string>state ( string -- state )
- dup states [ name>> = ] with find nip
- [ ] [ no-such-state ] ?if ;
+ [ states [ name>> = ] with find nip ]
+ [ no-such-state ] ?unless ;
TUPLE: city
first-zip name state latitude longitude gmt-offset dst-offset ;
swap >>cpu
swap >>os
swap >>host-name
- dup select-tuple [ ] [ dup insert-tuple ] ?if ;
+ [ select-tuple ] [ dup insert-tuple ] ?unless ;
: heartbeat ( builder -- )
now >>heartbeat-timestamp
'[ _ dup random-url >>short insert-tuple ] 10 retry ;
: shorten ( url -- short )
- short-url new swap >>url dup select-tuple
- [ ] [ insert-short-url ] ?if short>> ;
+ short-url new swap >>url
+ [ select-tuple ] [ insert-short-url ] ?unless short>> ;
: short>url ( short -- url )
"$wee-url/go/" prepend >url adjust-url ;
[ validate-title ] >>init
[
- "title" value dup latest-revision [
+ "title" value
+ [
+ latest-revision
+ ] [
from-object
{ wiki "view" } <chloe-content>
] [
edit-url <redirect>
- ] ?if
+ ] ??if
] >>display
<article-boilerplate> ;
projects / factor.git / commitdiff