<PRIVATE
: init-struct ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
- '[ dup struct-prototype _ _ ?if-old ] keep memory>struct ; inline
+ '[ [ struct-prototype ] _ _ ?if ] keep memory>struct ; inline
PRIVATE>
[ [ 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-old ;
+ ] [ 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-old ;
+ ] [ 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-old ;
+ ] [ emit-primitive ] ?if ;
: emit-identity-hashcode ( -- )
[
insn ;
: check-redundancy ( insn -- insn' )
- dup >expr dup exprs>vns get at
- [ redundant-instruction ] [ useful-instruction ] ?if-old ;
+ dup >expr
+ [ exprs>vns get at ] [ redundant-instruction ] [ useful-instruction ] ?if ;
M: insn process-instruction
- dup rewrite [ process-instruction ] [ ] ?if-old ;
+ [ rewrite ] [ process-instruction ] ?when ;
M: foldable-insn process-instruction
- dup rewrite
+ [ rewrite ]
[ process-instruction ]
- [ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if-old ;
+ [ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if ;
M: ##copy process-instruction
dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
GENERIC: mailbox-of ( thread -- mailbox )
M: thread mailbox-of
- dup mailbox>>
+ [ mailbox>> ]
[ { mailbox } declare ]
- [ <mailbox> [ >>mailbox drop ] keep ] ?if-old ; inline
+ [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
M: thread send
mailbox-of mailbox-put ;
ERROR: no-such-responder responder ;
: base-path ( string -- seq )
- dup responder-nesting get
- [ second class-of superclasses-of [ name>> = ] with any? ] with find nip
- [ first ] [ no-such-responder ] ?if-old ;
+ [
+ responder-nesting get
+ [ second class-of superclasses-of [ name>> = ] with any? ] with find nip
+ ] [ first ] [ no-such-responder ] ?if ;
: resolve-base-path ( string -- string' )
"$" ?head [
: serve-file ( filename -- response )
dup mime-type
- dup file-responder get special>> at
- [ call( filename -- response ) ] [ serve-static ] ?if-old ;
+ [ file-responder get special>> at ]
+ [ call( filename -- response ) ] [ serve-static ] ?if ;
\ serve-file NOTICE add-input-logging
: serve-directory ( filename -- response )
url get path>> "/" tail? [
- dup
- find-index [ serve-file ] [ list-directory ] ?if-old
+ [ find-index ] [ serve-file ] [ list-directory ] ?if
] [
drop
url get clone [ "/" append ] change-path <permanent-redirect>
[
"}" split1-slice
[
- >string dup string>number
+ >string
+ [ string>number ]
[ 1 + stack-var boa ]
- [ [ anon-var new ] [ named-var boa ] if-empty ] ?if-old ,
+ [ [ anon-var new ] [ named-var boa ] if-empty ] ?if ,
]
[ (parse-interpolate) ] bi*
] when*
[ interpolate ] with-string-writer ; inline
: interpolate-locals-quot ( str -- quot )
- [ dup search [ [ ] ] [ [ get ] ] ?if-old ] (interpolate-quot) ;
+ [ [ search ] [ [ ] ] [ [ get ] ] ?if ] (interpolate-quot) ;
MACRO: interpolate-locals ( str -- quot )
interpolate-locals-quot ;
{ [ length 2 = ] [ first quad-1/3? ] [ second quad-2/4? ] } 1&& ;
: decode-quad ( byte-array -- char )
- dup mapping get-global value-at [ ] [
+ [ mapping get-global value-at ] [
linear dup gb>u get-global interval-at [
[ bfirst>> - ] [ ufirst>> ] bi +
] [ drop replacement-char ] if*
- ] ?if-old ;
+ ] ?unless ;
: four-byte ( stream byte1 byte2 -- char )
rot 2 swap stream-read dup last-bytes?
{ [ "0" = not ] [ "0" head? ] [ "0x" head? not ] } 1&& ;
: ipv4-component ( str -- n )
- dup dup octal? [ oct> ] [ string>number ] if
- [ ] [ bad-ipv4-component ] ?if-old ;
+ [ dup octal? [ oct> ] [ string>number ] if ]
+ [ bad-ipv4-component ] ?unless ;
: split-ipv4 ( str -- array )
"." split [ ipv4-component ] map ;
<PRIVATE
: ipv6-component ( str -- n )
- dup hex> [ ] [ bad-ipv6-component ] ?if-old ;
+ [ hex> ] [ bad-ipv6-component ] ?unless ;
: 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-old ]
+ [ [ string>number ] [ not-a-json-number ] ?unless ]
} case
] dip ;
ERROR: bad-integer-op word ;
M: word integer-op-input-classes
- dup "input-classes" word-prop
- [ ] [ bad-integer-op ] ?if-old ;
+ [ "input-classes" word-prop ]
+ [ bad-integer-op ] ?unless ;
: generic-variant ( op -- generic-op/f )
- dup "derived-from" word-prop [ first ] [ ] ?if-old ;
+ [ "derived-from" word-prop ] [ first ] ?when ;
: no-overflow-variant ( op -- fast-op )
H{
[
def call compile :> compiled-def
word [
- dup compiled-def compiled-parse
- [ ast>> ] [ word parse-failed ] ?if-old
+ [ compiled-def compiled-parse ]
+ [ ast>> ]
+ [ word parse-failed ] ?if
] effect define-declared
] with-compilation-unit
] append!
simple-category-table at <category-class>
] }
{ [ "script=" ?head ] [
- dup simple-script-table at
+ [ simple-script-table at ]
[ <script-class> ]
- [ "script=" prepend bad-class ] ?if-old
+ [ "script=" prepend bad-class ] ?if
] }
[ bad-class ]
} cond ;
: unicode-class ( name -- class )
- dup parse-unicode-class [ ] [ bad-class ] ?if-old ;
+ [ parse-unicode-class ] [ bad-class ] ?unless ;
: name>class ( name -- class )
>string simple {
ERROR: nonexistent-option name ;
: ch>option ( ch -- singleton )
- dup options-assoc at [ ] [ nonexistent-option ] ?if-old ;
+ [ options-assoc at ] [ nonexistent-option ] ?unless ;
: 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-old ; foldable
+ [ [ name>> "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup-word ]
+ [ specialized-array-vocab-not-loaded ] ?unless ; 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-old ; foldable
+ [ [ name>> "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup-word ]
+ [ specialized-array-vocab-not-loaded ] ?unless ; 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-old ; foldable
+ [ [ name>> "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup-word ]
+ [ specialized-array-vocab-not-loaded ] ?unless ; 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-old ; foldable
+ [ [ name>> "-array" append ] [ specialized-array-vocab ] bi lookup-word ]
+ [ specialized-array-vocab-not-loaded ] ?unless ; 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-old ; foldable
+ [ [ name>> "-array?" append ] [ specialized-array-vocab ] bi lookup-word ]
+ [ specialized-array-vocab-not-loaded ] ?unless ; 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-old ;
+ [ stack-effect ] [ missing-effect ] ?unless ;
: with-infer ( quot -- effect visitor )
[
] if ;
: chop-; ( seq -- seq' )
- { ";" } split1-last [ ] [ ] ?if-old ;
+ { ";" } split1-last swap or ;
: complete-vocab-list? ( tokens -- ? )
chop-; 1 index-or-length head* "USING:" swap member? ;
ERROR: can't-deploy-library-file library ;
: copy-library ( dir library -- )
- dup find-library*
+ [ find-library* ]
[ tuck file-name append-path copy-file ]
- [ can't-deploy-library-file ] ?if-old ;
+ [ can't-deploy-library-file ] ?if ;
: copy-libraries ( manifest name dir -- )
append-path swap libraries>> [ copy-library ] with each ;
! that this gives Cf or Mn
! Cf = 26; Mn = 5; Cn = 29
! Use a compressed array instead?
- dup category-map ?nth [ ] [
+ [ category-map ?nth ] [
dup 0xE0001 0xE007F between?
[ drop 26 ] [
0xE0100 0xE01EF between? 5 29 ?
] if
- ] ?if-old ; inline
+ ] ?unless ; inline
: category ( char -- category )
category-num categories nth ;
M: tuple hashcode* [ tuple-hashcode ] recursive-hashcode ;
M: tuple-class new
- dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if-old ;
+ [ "prototype" word-prop ] [ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop [ call ] when* ]
ERROR: no-next-method method ;
: (call-next-method) ( method -- )
- dup next-method-quot [ call ] [ no-next-method ] ?if-old ;
+ [ next-method-quot ] [ call ] [ no-next-method ] ?if ;
ERROR: check-method-error class generic ;