: <bit-array> ( n -- bit-array )
dup bits>bytes <byte-array> bit-array boa ; inline
-M: bit-array length length>> ;
+M: bit-array length length>> ; inline
M: bit-array nth-unsafe
- [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
+ [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
M: bit-array set-nth-unsafe
[ >fixnum ] [ underlying>> ] bi*
[ byte/bit set-bit ] 2keep
- swap n>byte set-alien-unsigned-1 ;
+ swap n>byte set-alien-unsigned-1 ; inline
GENERIC: clear-bits ( bit-array -- )
-M: bit-array clear-bits 0 (set-bits) ;
+M: bit-array clear-bits 0 (set-bits) ; inline
GENERIC: set-bits ( bit-array -- )
-M: bit-array set-bits -1 (set-bits) ;
+M: bit-array set-bits -1 (set-bits) ; inline
M: bit-array clone
- [ length>> ] [ underlying>> clone ] bi bit-array boa ;
+ [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
: >bit-array ( seq -- bit-array )
T{ bit-array f 0 B{ } } clone-like ; inline
-M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
+M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
-M: bit-array new-sequence drop <bit-array> ;
+M: bit-array new-sequence drop <bit-array> ; inline
M: bit-array equal?
over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
resize-byte-array
] 2bi
bit-array boa
- dup clean-up ;
+ dup clean-up ; inline
M: bit-array byte-length length 7 + -3 shift ;
M: chunking-seq set-nth group@ <slice> 0 swap copy ;
-M: chunking-seq like drop { } like ;
+M: chunking-seq like drop { } like ; inline
INSTANCE: chunking-seq sequence
MIXIN: subseq-chunking
-M: subseq-chunking nth group@ subseq ;
+M: subseq-chunking nth group@ subseq ; inline
MIXIN: slice-chunking
-M: slice-chunking nth group@ <slice> ;
+M: slice-chunking nth group@ <slice> ; inline
-M: slice-chunking nth-unsafe group@ slice boa ;
+M: slice-chunking nth-unsafe group@ slice boa ; inline
TUPLE: abstract-groups < chunking-seq ;
M: abstract-groups length
- [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ;
+ [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline
M: abstract-groups set-length
- [ n>> * ] [ seq>> ] bi set-length ;
+ [ n>> * ] [ seq>> ] bi set-length ; inline
M: abstract-groups group@
- [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
+ [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline
TUPLE: abstract-clumps < chunking-seq ;
M: abstract-clumps length
- [ seq>> length ] [ n>> ] bi - 1 + ;
+ [ seq>> length ] [ n>> ] bi - 1 + ; inline
M: abstract-clumps set-length
- [ n>> + 1 - ] [ seq>> ] bi set-length ;
+ [ n>> + 1 - ] [ seq>> ] bi set-length ; inline
M: abstract-clumps group@
- [ n>> over + ] [ seq>> ] bi ;
+ [ n>> over + ] [ seq>> ] bi ; inline
PRIVATE>
SINGLETON: ascii
M: ascii encode-char
- 128 encode-if< ;
+ 128 encode-if< ; inline
M: ascii decode-char
- 128 decode-if< ;
+ 128 decode-if< ; inline
: make-bits ( number -- bits )
[ T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if-zero ; inline
-M: bits length length>> ;
+M: bits length length>> ; inline
-M: bits nth-unsafe number>> swap bit? ;
+M: bits nth-unsafe number>> swap bit? ; inline
INSTANCE: bits immutable-sequence
parser ;
IN: math.complex.private
-M: real real-part ;
-M: real imaginary-part drop 0 ;
-M: complex real-part real>> ;
-M: complex imaginary-part imaginary>> ;
-M: complex absq >rect [ sq ] bi@ + ;
-M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ;
+M: real real-part ; inline
+M: real imaginary-part drop 0 ; inline
+M: complex real-part real>> ; inline
+M: complex imaginary-part imaginary>> ; inline
+M: complex absq >rect [ sq ] bi@ + ; inline
+M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; inline
: componentwise ( x y quot -- a b ) [ [ >rect ] bi@ ] dip bi-curry@ bi* ; inline
: complex= ( x y quot -- ? ) componentwise and ; inline
-M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ;
-M: complex number= [ number= ] complex= ;
+M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; inline
+M: complex number= [ number= ] complex= ; inline
: complex-op ( x y quot -- z ) componentwise rect> ; inline
-M: complex + [ + ] complex-op ;
-M: complex - [ - ] complex-op ;
+M: complex + [ + ] complex-op ; inline
+M: complex - [ - ] complex-op ; inline
: *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline
: *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline
-M: complex * [ *re - ] [ *im + ] 2bi rect> ;
+M: complex * [ *re - ] [ *im + ] 2bi rect> ; inline
: (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline
-M: complex / [ / ] complex/ ;
-M: complex /f [ /f ] complex/ ;
-M: complex /i [ /i ] complex/ ;
-M: complex abs absq >float fsqrt ;
-M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ;
+M: complex / [ / ] complex/ ; inline
+M: complex /f [ /f ] complex/ ; inline
+M: complex /i [ /i ] complex/ ; inline
+M: complex abs absq >float fsqrt ; inline
+M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline
IN: syntax
GENERIC: sqrt ( x -- y ) foldable
M: real sqrt
- >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
+ >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; inline
: factor-2s ( n -- r s )
#! factor an integer into 2^r * s
GENERIC: absq ( x -- y ) foldable
-M: real absq sq ;
+M: real absq sq ; inline
: ~abs ( x y epsilon -- ? )
[ - abs ] dip < ;
GENERIC: exp ( x -- y )
-M: real exp fexp ;
+M: real exp fexp ; inline
M: complex exp >rect swap fexp swap polar> ;
GENERIC: log ( x -- y )
-M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ;
+M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
M: complex log >polar swap flog swap rect> ;
[ [ fcos ] [ fcosh ] bi* * ]
[ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
-M: real cos fcos ;
+M: real cos fcos ; inline
: sec ( x -- y ) cos recip ; inline
[ [ fcosh ] [ fcos ] bi* * ]
[ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
-M: real cosh fcosh ;
+M: real cosh fcosh ; inline
: sech ( x -- y ) cosh recip ; inline
[ [ fsin ] [ fcosh ] bi* * ]
[ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
-M: real sin fsin ;
+M: real sin fsin ; inline
: cosec ( x -- y ) sin recip ; inline
[ [ fsinh ] [ fcos ] bi* * ]
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
-M: real sinh fsinh ;
+M: real sinh fsinh ; inline
: cosech ( x -- y ) sinh recip ; inline
M: complex tan [ sin ] [ cos ] bi / ;
-M: real tan ftan ;
+M: real tan ftan ; inline
GENERIC: tanh ( x -- y ) foldable
M: complex tanh [ sinh ] [ cosh ] bi / ;
-M: real tanh ftanh ;
+M: real tanh ftanh ; inline
: cot ( x -- y ) tan recip ; inline
M: complex atan i* atanh i* ;
-M: real atan fatan ;
+M: real atan fatan ; inline
: asec ( x -- y ) recip acos ; inline
: <range> ( a b step -- range )
[ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline
-M: range length ( seq -- n )
- length>> ;
+M: range length ( seq -- n ) length>> ; inline
-M: range nth-unsafe ( n range -- obj )
- [ step>> * ] keep from>> + ;
+M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline
! For ranges with many elements, the default element-wise methods
! sequences define are unsuitable because they're O(n)
M: ratio >bignum >fraction /i >bignum ;
M: ratio >float >fraction /f ;
-M: ratio numerator numerator>> ;
-M: ratio denominator denominator>> ;
+M: ratio numerator numerator>> ; inline
+M: ratio denominator denominator>> ; inline
M: ratio < scale < ;
M: ratio <= scale <= ;
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
+\ <tuple-boa> t "flushable" set-word-prop
+
: infer-effect-unsafe ( word -- )
pop-literal nip
add-effect-input
[ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
\ CLASS-array boa ; inline
-M: CLASS-array length length>> ;
+M: CLASS-array length length>> ; inline
-M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ;
+M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; inline
-M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ;
+M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; inline
-M: CLASS-array new-sequence drop <CLASS-array> ;
+M: CLASS-array new-sequence drop <CLASS-array> ; inline
: >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
-M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ;
+M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; inline
INSTANCE: CLASS-array sequence
M: V like
drop dup V instance? [
dup A instance? [ dup length V boa ] [ >V ] if
- ] unless ;
+ ] unless ; inline
-M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
+M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ; inline
-M: A new-resizable drop <V> ;
+M: A new-resizable drop <V> ; inline
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
GENERIC: >c-ptr ( obj -- c-ptr )
-M: c-ptr >c-ptr ;
+M: c-ptr >c-ptr ; inline
SLOT: underlying
-M: object >c-ptr underlying>> ;
+M: object >c-ptr underlying>> ; inline
GENERIC: expired? ( c-ptr -- ? ) flushable
sequences sequences.private ;
IN: arrays
-M: array clone (clone) ;
-M: array length length>> ;
-M: array nth-unsafe [ >fixnum ] dip array-nth ;
-M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ;
-M: array resize resize-array ;
+M: array clone (clone) ; inline
+M: array length length>> ; inline
+M: array nth-unsafe [ >fixnum ] dip array-nth ; inline
+M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline
+M: array resize resize-array ; inline
: >array ( seq -- array ) { } clone-like ;
-M: object new-sequence drop 0 <array> ;
+M: object new-sequence drop 0 <array> ; inline
-M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ;
+M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ; inline
M: array equal?
over array? [ sequence= ] [ 2drop f ] if ;
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
GENERIC: >alist ( assoc -- newassoc )
-M: assoc assoc-like drop ;
+M: assoc assoc-like drop ; inline
: ?at ( key assoc -- value/key ? )
2dup at* [ 2nip t ] [ 2drop f ] if ; inline
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ dup assoc-size ] dip new-assoc
- [ [ set-at ] with-assoc assoc-each ] keep ;
+ [ [ set-at ] with-assoc assoc-each ] keep ; inline
: keys ( assoc -- keys )
[ drop ] { } assoc>map ;
[ 2nip set-second ]
[ drop [ swap 2array ] dip push ] if ;
-M: sequence new-assoc drop <vector> ;
+M: sequence new-assoc drop <vector> ; inline
-M: sequence clear-assoc delete-all ;
+M: sequence clear-assoc delete-all ; inline
M: sequence delete-at
[ nip ] [ search-alist nip ] 2bi
[ swap delete-nth ] [ drop ] if* ;
-M: sequence assoc-size length ;
+M: sequence assoc-size length ; inline
M: sequence assoc-clone-like
- [ >alist ] dip clone-like ;
+ [ >alist ] dip clone-like ; inline
M: sequence assoc-like
- [ >alist ] dip like ;
+ [ >alist ] dip like ; inline
-M: sequence >alist ;
+M: sequence >alist ; inline
! Override sequence => assoc instance for f
-M: f clear-assoc drop ;
+M: f clear-assoc drop ; inline
-M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
+M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline
INSTANCE: sequence assoc
-TUPLE: enum seq ;
+TUPLE: enum { seq read-only } ;
C: <enum> enum
M: enum at*
seq>> 2dup bounds-check?
- [ nth t ] [ 2drop f f ] if ;
+ [ nth t ] [ 2drop f f ] if ; inline
-M: enum set-at seq>> set-nth ;
+M: enum set-at seq>> set-nth ; inline
-M: enum delete-at seq>> delete-nth ;
+M: enum delete-at seq>> delete-nth ; inline
M: enum >alist ( enum -- alist )
- seq>> [ length ] keep zip ;
+ seq>> [ length ] keep zip ; inline
-M: enum assoc-size seq>> length ;
+M: enum assoc-size seq>> length ; inline
-M: enum clear-assoc seq>> delete-all ;
+M: enum clear-assoc seq>> delete-all ; inline
INSTANCE: enum assoc
sequences.private math ;
IN: byte-arrays
-M: byte-array clone (clone) ;
-M: byte-array length length>> ;
-M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
-M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
+M: byte-array clone (clone) ; inline
+M: byte-array length length>> ; inline
+M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; inline
+M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; inline
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
-M: byte-array new-sequence drop (byte-array) ;
+M: byte-array new-sequence drop (byte-array) ; inline
M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ;
M: byte-array resize
- resize-byte-array ;
+ resize-byte-array ; inline
INSTANCE: byte-array sequence
drop dup byte-vector? [\r
dup byte-array?\r
[ dup length byte-vector boa ] [ >byte-vector ] if\r
- ] unless ;\r
+ ] unless ; inline\r
\r
M: byte-vector new-sequence\r
- drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;\r
+ drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; inline\r
\r
M: byte-vector equal?\r
over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
\r
-M: byte-vector contract 2drop ;\r
+M: byte-vector contract 2drop ; inline\r
\r
M: byte-array like\r
#! If we have an byte-array, we're done.\r
2dup length eq?\r
[ nip ] [ resize-byte-array ] if\r
] [ >byte-array ] if\r
- ] unless ;\r
+ ] unless ; inline\r
\r
-M: byte-array new-resizable drop <byte-vector> ;\r
+M: byte-array new-resizable drop <byte-vector> ; inline\r
\r
INSTANCE: byte-vector growable\r
: bootstrap-type>class ( n -- class ) builtins get nth ;
-M: hi-tag class hi-tag type>class ;
+M: hi-tag class hi-tag type>class ; inline
-M: object class tag type>class ;
+M: object class tag type>class ; inline
M: builtin-class rank-class drop 0 ;
: layout-of ( tuple -- layout )
1 slot { array } declare ; inline
-M: tuple class layout-of 2 slot { word } declare ;
+M: tuple class layout-of 2 slot { word } declare ; inline
: tuple-size ( tuple -- size )
layout-of 3 slot { fixnum } declare ; inline
[ swap classes-intersect? ]
} cond ;
-M: tuple clone (clone) ;
+M: tuple clone (clone) ; inline
M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
SLOT: length
SLOT: underlying
-M: growable length length>> ;
-M: growable nth-unsafe underlying>> nth-unsafe ;
-M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
+M: growable length length>> ; inline
+M: growable nth-unsafe underlying>> nth-unsafe ; inline
+M: growable set-nth-unsafe underlying>> set-nth-unsafe ; inline
: capacity ( seq -- n ) underlying>> length ; inline
[ >fixnum ] dip
] if ; inline
-M: growable set-nth ensure set-nth-unsafe ;
+M: growable set-nth ensure set-nth-unsafe ; inline
-M: growable clone (clone) [ clone ] change-underlying ;
+M: growable clone (clone) [ clone ] change-underlying ; inline
M: growable lengthen ( n seq -- )
2dup length > [
2dup capacity > [ over new-size over expand ] when
2dup (>>length)
- ] when 2drop ;
+ ] when 2drop ; inline
M: growable shorten ( n seq -- )
growable-check
2dup length < [
2dup contract
2dup (>>length)
- ] when 2drop ;
+ ] when 2drop ; inline
INSTANCE: growable sequence
] if ;
M: hashtable assoc-size ( hash -- n )
- [ count>> ] [ deleted>> ] bi - ;
+ [ count>> ] [ deleted>> ] bi - ; inline
: rehash ( hash -- )
dup >alist [
] keep { } like ;
M: hashtable clone
- (clone) [ clone ] change-array ;
+ (clone) [ clone ] change-array ; inline
M: hashtable equal?
over hashtable? [
] [ 2drop f ] if ;
! Default method
-M: assoc new-assoc drop <hashtable> ;
+M: assoc new-assoc drop <hashtable> ; inline
-M: f new-assoc drop <hashtable> ;
+M: f new-assoc drop <hashtable> ; inline
: >hashtable ( assoc -- hashtable )
H{ } assoc-clone-like ;
M: hashtable assoc-like
- drop dup hashtable? [ >hashtable ] unless ;
+ drop dup hashtable? [ >hashtable ] unless ; inline
: ?set-at ( value key assoc/f -- assoc )
[ [ set-at ] keep ] [ associate ] if* ;
dup stream-read1 dup [ begin-utf8 ] when nip ; inline
M: utf8 decode-char
- drop decode-utf8 ;
+ drop decode-utf8 ; inline
! Encoding UTF-8
! Object protocol
GENERIC: hashcode* ( depth obj -- code )
-M: object hashcode* 2drop 0 ;
+M: object hashcode* 2drop 0 ; inline
-M: f hashcode* 2drop 31337 ;
+M: f hashcode* 2drop 31337 ; inline
: hashcode ( obj -- code ) 3 swap hashcode* ; inline
GENERIC: equal? ( obj1 obj2 -- ? )
-M: object equal? 2drop f ;
+M: object equal? 2drop f ; inline
TUPLE: identity-tuple ;
-M: identity-tuple equal? 2drop f ;
+M: identity-tuple equal? 2drop f ; inline
: = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [
GENERIC: clone ( obj -- cloned )
-M: object clone ;
+M: object clone ; inline
-M: callstack clone (clone) ;
+M: callstack clone (clone) ; inline
! Tuple construction
GENERIC: new ( class -- tuple )
M: real >integer
dup most-negative-fixnum most-positive-fixnum between?
- [ >fixnum ] [ >bignum ] if ;
+ [ >fixnum ] [ >bignum ] if ; inline
UNION: immediate fixnum POSTPONE: f ;
USING: kernel math math.private ;
IN: math.floats.private
-M: fixnum >float fixnum>float ;
-M: bignum >float bignum>float ;
+M: fixnum >float fixnum>float ; inline
+M: bignum >float bignum>float ; inline
-M: float >fixnum float>fixnum ;
-M: float >bignum float>bignum ;
-M: float >float ;
+M: float >fixnum float>fixnum ; inline
+M: float >bignum float>bignum ; inline
+M: float >float ; inline
-M: float hashcode* nip float>bits ;
-M: float equal? over float? [ float= ] [ 2drop f ] if ;
-M: float number= float= ;
+M: float hashcode* nip float>bits ; inline
+M: float equal? over float? [ float= ] [ 2drop f ] if ; inline
+M: float number= float= ; inline
-M: float < float< ;
-M: float <= float<= ;
-M: float > float> ;
-M: float >= float>= ;
+M: float < float< ; inline
+M: float <= float<= ; inline
+M: float > float> ; inline
+M: float >= float>= ; inline
-M: float + float+ ;
-M: float - float- ;
-M: float * float* ;
-M: float / float/f ;
-M: float /f float/f ;
-M: float /i float/f >integer ;
-M: float mod float-mod ;
+M: float + float+ ; inline
+M: float - float- ; inline
+M: float * float* ; inline
+M: float / float/f ; inline
+M: float /f float/f ; inline
+M: float /i float/f >integer ; inline
+M: float mod float-mod ; inline
-M: real abs dup 0 < [ neg ] when ;
+M: real abs dup 0 < [ neg ] when ; inline
sequences.private math math.private combinators ;
IN: math.integers.private
-M: integer numerator ;
-M: integer denominator drop 1 ;
+M: integer numerator ; inline
+M: integer denominator drop 1 ; inline
-M: fixnum >fixnum ;
-M: fixnum >bignum fixnum>bignum ;
-M: fixnum >integer ;
+M: fixnum >fixnum ; inline
+M: fixnum >bignum fixnum>bignum ; inline
+M: fixnum >integer ; inline
-M: fixnum hashcode* nip ;
-M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ;
-M: fixnum number= eq? ;
+M: fixnum hashcode* nip ; inline
+M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline
+M: fixnum number= eq? ; inline
-M: fixnum < fixnum< ;
-M: fixnum <= fixnum<= ;
-M: fixnum > fixnum> ;
-M: fixnum >= fixnum>= ;
+M: fixnum < fixnum< ; inline
+M: fixnum <= fixnum<= ; inline
+M: fixnum > fixnum> ; inline
+M: fixnum >= fixnum>= ; inline
-M: fixnum + fixnum+ ;
-M: fixnum - fixnum- ;
-M: fixnum * fixnum* ;
-M: fixnum /i fixnum/i ;
-M: fixnum /f [ >float ] dip >float float/f ;
+M: fixnum + fixnum+ ; inline
+M: fixnum - fixnum- ; inline
+M: fixnum * fixnum* ; inline
+M: fixnum /i fixnum/i ; inline
+M: fixnum /f [ >float ] dip >float float/f ; inline
-M: fixnum mod fixnum-mod ;
+M: fixnum mod fixnum-mod ; inline
-M: fixnum /mod fixnum/mod ;
+M: fixnum /mod fixnum/mod ; inline
-M: fixnum bitand fixnum-bitand ;
-M: fixnum bitor fixnum-bitor ;
-M: fixnum bitxor fixnum-bitxor ;
-M: fixnum shift >fixnum fixnum-shift ;
+M: fixnum bitand fixnum-bitand ; inline
+M: fixnum bitor fixnum-bitor ; inline
+M: fixnum bitxor fixnum-bitxor ; inline
+M: fixnum shift >fixnum fixnum-shift ; inline
-M: fixnum bitnot fixnum-bitnot ;
+M: fixnum bitnot fixnum-bitnot ; inline
-M: fixnum bit? neg shift 1 bitand 0 > ;
+M: fixnum bit? neg shift 1 bitand 0 > ; inline
: fixnum-log2 ( x -- n )
0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ;
-M: fixnum (log2) fixnum-log2 ;
+M: fixnum (log2) fixnum-log2 ; inline
-M: bignum >fixnum bignum>fixnum ;
-M: bignum >bignum ;
+M: bignum >fixnum bignum>fixnum ; inline
+M: bignum >bignum ; inline
M: bignum hashcode* nip >fixnum ;
M: bignum equal?
over bignum? [ bignum= ] [
swap dup fixnum? [ >bignum bignum= ] [ 2drop f ] if
- ] if ;
+ ] if ; inline
-M: bignum number= bignum= ;
+M: bignum number= bignum= ; inline
-M: bignum < bignum< ;
-M: bignum <= bignum<= ;
-M: bignum > bignum> ;
-M: bignum >= bignum>= ;
+M: bignum < bignum< ; inline
+M: bignum <= bignum<= ; inline
+M: bignum > bignum> ; inline
+M: bignum >= bignum>= ; inline
-M: bignum + bignum+ ;
-M: bignum - bignum- ;
-M: bignum * bignum* ;
-M: bignum /i bignum/i ;
-M: bignum mod bignum-mod ;
+M: bignum + bignum+ ; inline
+M: bignum - bignum- ; inline
+M: bignum * bignum* ; inline
+M: bignum /i bignum/i ; inline
+M: bignum mod bignum-mod ; inline
-M: bignum /mod bignum/mod ;
+M: bignum /mod bignum/mod ; inline
-M: bignum bitand bignum-bitand ;
-M: bignum bitor bignum-bitor ;
-M: bignum bitxor bignum-bitxor ;
-M: bignum shift >fixnum bignum-shift ;
+M: bignum bitand bignum-bitand ; inline
+M: bignum bitor bignum-bitor ; inline
+M: bignum bitxor bignum-bitxor ; inline
+M: bignum shift >fixnum bignum-shift ; inline
-M: bignum bitnot bignum-bitnot ;
-M: bignum bit? bignum-bit? ;
-M: bignum (log2) bignum-log2 ;
+M: bignum bitnot bignum-bitnot ; inline
+M: bignum bit? bignum-bit? ; inline
+M: bignum (log2) bignum-log2 ; inline
! Converting ratios to floats. Based on FLOAT-RATIO from
! sbcl/src/code/float.lisp, which has the following license:
GENERIC: fp-nan-payload ( x -- bits )
M: object fp-special?
- drop f ;
+ drop f ; inline
M: object fp-nan?
- drop f ;
+ drop f ; inline
M: object fp-qnan?
- drop f ;
+ drop f ; inline
M: object fp-snan?
- drop f ;
+ drop f ; inline
M: object fp-infinity?
- drop f ;
+ drop f ; inline
M: object fp-nan-payload
- drop f ;
+ drop f ; inline
M: float fp-special?
- double>bits -52 shift HEX: 7ff [ bitand ] keep = ;
+ double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline
M: float fp-nan-payload
- double>bits HEX: fffffffffffff bitand ; foldable flushable
+ double>bits HEX: fffffffffffff bitand ; inline
M: float fp-nan?
- dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ;
+ dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
M: float fp-qnan?
- dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ;
+ dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; inline
M: float fp-snan?
- dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ;
+ dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; inline
M: float fp-infinity?
- dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ;
+ dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
: <fp-nan> ( payload -- nan )
- HEX: 7ff0000000000000 bitor bits>double ; foldable flushable
+ HEX: 7ff0000000000000 bitor bits>double ; inline
: next-float ( m -- n )
double>bits
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
1 + bits>double ! positive
] if
- ] if ; foldable flushable
+ ] if ; inline
: prev-float ( m -- n )
double>bits
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
1 - bits>double ! positive non-zero
] if
- ] if ; foldable flushable
+ ] if ; inline
: next-power-of-2 ( m -- n )
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
: >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline
-M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
+M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
GENERIC: before? ( obj1 obj2 -- ? )
GENERIC: after? ( obj1 obj2 -- ? )
GENERIC: before=? ( obj1 obj2 -- ? )
GENERIC: after=? ( obj1 obj2 -- ? )
-M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ;
-M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ;
-M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ;
-M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ;
+M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; inline
+M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; inline
+M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; inline
+M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; inline
-M: real before? ( obj1 obj2 -- ? ) < ;
-M: real after? ( obj1 obj2 -- ? ) > ;
-M: real before=? ( obj1 obj2 -- ? ) <= ;
-M: real after=? ( obj1 obj2 -- ? ) >= ;
+M: real before? ( obj1 obj2 -- ? ) < ; inline
+M: real after? ( obj1 obj2 -- ? ) > ; inline
+M: real before=? ( obj1 obj2 -- ? ) <= ; inline
+M: real after=? ( obj1 obj2 -- ? ) >= ; inline
-: min ( x y -- z ) [ before? ] most ; inline
+: min ( x y -- z ) [ before? ] most ; inline
: max ( x y -- z ) [ after? ] most ; inline
: clamp ( x min max -- y ) [ max ] dip min ; inline
: <sbuf> ( n -- sbuf ) 0 <string> 0 sbuf boa ; inline
M: sbuf set-nth-unsafe
- [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ;
+ [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; inline
M: sbuf new-sequence
- drop [ 0 <string> ] [ >fixnum ] bi sbuf boa ;
+ drop [ 0 <string> ] [ >fixnum ] bi sbuf boa ; inline
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline
M: sbuf like
drop dup sbuf? [
dup string? [ dup length sbuf boa ] [ >sbuf ] if
- ] unless ;
+ ] unless ; inline
-M: sbuf new-resizable drop <sbuf> ;
+M: sbuf new-resizable drop <sbuf> ; inline
M: sbuf equal?
over sbuf? [ sequence= ] [ 2drop f ] if ;
-M: string new-resizable drop <sbuf> ;
+M: string new-resizable drop <sbuf> ; inline
M: string like
#! If we have a string, we're done.
2dup length eq?
[ nip dup reset-string-hashcode ] [ resize-string ] if
] [ >string ] if
- ] unless ;
+ ] unless ; inline
INSTANCE: sbuf growable
: new-like ( len exemplar quot -- seq )
over [ [ new-sequence ] dip call ] dip like ; inline
-M: sequence like drop ;
+M: sequence like drop ; inline
GENERIC: lengthen ( n seq -- )
GENERIC: shorten ( n seq -- )
-M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
+M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; inline
-M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
+M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline
: empty? ( seq -- ? ) length 0 = ; inline
GENERIC: nth-unsafe ( n seq -- elt ) flushable
GENERIC: set-nth-unsafe ( elt n seq -- )
-M: sequence nth bounds-check nth-unsafe ;
-M: sequence set-nth bounds-check set-nth-unsafe ;
+M: sequence nth bounds-check nth-unsafe ; inline
+M: sequence set-nth bounds-check set-nth-unsafe ; inline
-M: sequence nth-unsafe nth ;
-M: sequence set-nth-unsafe set-nth ;
+M: sequence nth-unsafe nth ; inline
+M: sequence set-nth-unsafe set-nth ; inline
: change-nth-unsafe ( i seq quot -- )
[ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline
! The f object supports the sequence protocol trivially
-M: f length drop 0 ;
-M: f nth-unsafe nip ;
-M: f like drop [ f ] when-empty ;
+M: f length drop 0 ; inline
+M: f nth-unsafe nip ; inline
+M: f like drop [ f ] when-empty ; inline
INSTANCE: f immutable-sequence
! Integers support the sequence protocol
-M: integer length ;
-M: integer nth-unsafe drop ;
+M: integer length ; inline
+M: integer nth-unsafe drop ; inline
INSTANCE: integer immutable-sequence
<PRIVATE
-M: iota length n>> ;
-M: iota nth-unsafe drop ;
+M: iota length n>> ; inline
+M: iota nth-unsafe drop ; inline
INSTANCE: iota immutable-sequence
GENERIC: virtual-seq ( seq -- seq' )
GENERIC: virtual@ ( n seq -- n' seq' )
-M: virtual-sequence nth virtual@ nth ;
-M: virtual-sequence set-nth virtual@ set-nth ;
-M: virtual-sequence nth-unsafe virtual@ nth-unsafe ;
-M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ;
-M: virtual-sequence like virtual-seq like ;
-M: virtual-sequence new-sequence virtual-seq new-sequence ;
+M: virtual-sequence nth virtual@ nth ; inline
+M: virtual-sequence set-nth virtual@ set-nth ; inline
+M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; inline
+M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; inline
+M: virtual-sequence like virtual-seq like ; inline
+M: virtual-sequence new-sequence virtual-seq new-sequence ; inline
INSTANCE: virtual-sequence sequence
C: <reversed> reversed
-M: reversed virtual-seq seq>> ;
-
-M: reversed virtual@ seq>> [ length swap - 1 - ] keep ;
-
-M: reversed length seq>> length ;
+M: reversed virtual-seq seq>> ; inline
+M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; inline
+M: reversed length seq>> length ; inline
INSTANCE: reversed virtual-sequence
check-slice
slice boa ; inline
-M: slice virtual-seq seq>> ;
+M: slice virtual-seq seq>> ; inline
-M: slice virtual@ [ from>> + ] [ seq>> ] bi ;
+M: slice virtual@ [ from>> + ] [ seq>> ] bi ; inline
-M: slice length [ to>> ] [ from>> ] bi - ;
+M: slice length [ to>> ] [ from>> ] bi - ; inline
: short ( seq n -- seq n' ) over length min ; inline
C: <repetition> repetition
-M: repetition length len>> ;
-M: repetition nth-unsafe nip elt>> ;
+M: repetition length len>> ; inline
+M: repetition nth-unsafe nip elt>> ; inline
INSTANCE: repetition immutable-sequence
(copy) drop ; inline
M: sequence clone-like
- [ dup length ] dip new-sequence [ 0 swap copy ] keep ;
+ [ dup length ] dip new-sequence [ 0 swap copy ] keep ; inline
-M: immutable-sequence clone-like like ;
+M: immutable-sequence clone-like like ; inline
: push-all ( src dest -- ) [ length ] [ copy ] bi ;
[ create-method ] 2dip
[ [ props>> ] [ drop ] [ ] tri* update ]
[ drop define ]
- 3bi ;
+ [ 2drop make-inline ]
+ 3tri ;
GENERIC# reader-quot 1 ( class slot-spec -- quot )
dup t "reader" set-word-prop ;
: reader-props ( slot-spec -- assoc )
- [
- [ "reading" set ]
- [ read-only>> [ t "foldable" set ] when ] bi
- t "flushable" set
- ] H{ } make-assoc ;
+ "reading" associate ;
: define-reader-generic ( name -- )
reader-word (( object -- value )) define-simple-generic ;
[ ] [ dup rehash-string string-hashcode ] ?if ;
M: string length
- length>> ;
+ length>> ; inline
M: string nth-unsafe
- [ >fixnum ] dip string-nth ;
+ [ >fixnum ] dip string-nth ; inline
M: string set-nth-unsafe
dup reset-string-hashcode
- [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ;
+ [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; inline
M: string clone
- (clone) [ clone ] change-aux ;
+ (clone) [ clone ] change-aux ; inline
-M: string resize resize-string ;
+M: string resize resize-string ; inline
: 1string ( ch -- str ) 1 swap <string> ;
: >string ( seq -- str ) "" clone-like ;
-M: string new-sequence drop 0 <string> ;
+M: string new-sequence drop 0 <string> ; inline
INSTANCE: string sequence
M: vector like
drop dup vector? [
dup array? [ dup length vector boa ] [ >vector ] if
- ] unless ;
+ ] unless ; inline
M: vector new-sequence
- drop [ f <array> ] [ >fixnum ] bi vector boa ;
+ drop [ f <array> ] [ >fixnum ] bi vector boa ; inline
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;
2dup length eq?
[ nip ] [ resize-array ] if
] [ >array ] if
- ] unless ;
+ ] unless ; inline
-M: sequence new-resizable drop <vector> ;
+M: sequence new-resizable drop <vector> ; inline
INSTANCE: vector growable
M: word execute (execute) ;
-M: word ?execute execute( -- value ) ;
+M: word ?execute execute( -- value ) ; inline
M: word <=>
[ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
] if ;
M: word hashcode*
- nip 1 slot { fixnum } declare ; foldable
+ nip 1 slot { fixnum } declare ; inline foldable
M: word literalize <wrapper> ;