2009-04-25 20:41:27 -04:00
|
|
|
! Copyright (C) 2007, 2009 Slava Pestov.
|
2007-09-20 18:09:08 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2008-03-12 02:54:29 -04:00
|
|
|
USING: namespaces math words kernel assocs classes
|
2008-04-26 00:12:44 -04:00
|
|
|
math.order kernel.private ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: layouts
|
|
|
|
|
|
|
|
SYMBOL: tag-mask
|
|
|
|
|
|
|
|
SYMBOL: num-tags
|
|
|
|
|
|
|
|
SYMBOL: tag-bits
|
|
|
|
|
|
|
|
SYMBOL: num-types
|
|
|
|
|
|
|
|
SYMBOL: tag-numbers
|
|
|
|
|
|
|
|
SYMBOL: type-numbers
|
|
|
|
|
2009-04-30 05:14:14 -04:00
|
|
|
SYMBOL: mega-cache-size
|
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
: type-number ( class -- n )
|
|
|
|
type-numbers get at ;
|
|
|
|
|
2009-04-25 20:41:27 -04:00
|
|
|
: tag-number ( class -- n )
|
|
|
|
type-number dup num-tags get >= [ drop object tag-number ] when ;
|
|
|
|
|
2008-01-02 19:36:36 -05:00
|
|
|
: tag-fixnum ( n -- tagged )
|
2007-09-20 18:09:08 -04:00
|
|
|
tag-bits get shift ;
|
|
|
|
|
2008-09-27 12:39:14 -04:00
|
|
|
! We do this in its own compilation unit so that they can be
|
|
|
|
! folded below
|
|
|
|
<<
|
2008-03-12 02:54:29 -04:00
|
|
|
: cell ( -- n ) 7 getenv ; foldable
|
|
|
|
|
2008-09-27 12:39:14 -04:00
|
|
|
: (first-bignum) ( m -- n ) tag-bits get - 1 - 2^ ; foldable
|
|
|
|
>>
|
|
|
|
|
2008-03-12 02:54:29 -04:00
|
|
|
: cells ( m -- n ) cell * ; inline
|
|
|
|
|
|
|
|
: cell-bits ( -- n ) 8 cells ; inline
|
|
|
|
|
2008-12-15 20:44:56 -05:00
|
|
|
: bootstrap-cell ( -- n ) \ cell get cell or ; inline
|
2008-03-12 02:54:29 -04:00
|
|
|
|
2008-12-15 20:44:56 -05:00
|
|
|
: bootstrap-cells ( m -- n ) bootstrap-cell * ; inline
|
2008-03-12 02:54:29 -04:00
|
|
|
|
2008-12-15 20:44:56 -05:00
|
|
|
: bootstrap-cell-bits ( -- n ) 8 bootstrap-cells ; inline
|
2008-03-12 02:54:29 -04:00
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
: first-bignum ( -- n )
|
2008-09-27 12:39:14 -04:00
|
|
|
cell-bits (first-bignum) ; inline
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: most-positive-fixnum ( -- n )
|
2008-09-27 12:39:14 -04:00
|
|
|
first-bignum 1- ; inline
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: most-negative-fixnum ( -- n )
|
2008-09-27 12:39:14 -04:00
|
|
|
first-bignum neg ; inline
|
2008-02-22 00:47:06 -05:00
|
|
|
|
2008-06-29 03:12:44 -04:00
|
|
|
: (max-array-capacity) ( b -- n )
|
2008-09-27 12:39:14 -04:00
|
|
|
5 - 2^ 1- ; inline
|
2008-06-29 03:12:44 -04:00
|
|
|
|
|
|
|
: max-array-capacity ( -- n )
|
2008-09-27 12:39:14 -04:00
|
|
|
cell-bits (max-array-capacity) ; inline
|
2008-06-29 03:12:44 -04:00
|
|
|
|
2008-03-12 02:54:29 -04:00
|
|
|
: bootstrap-first-bignum ( -- n )
|
|
|
|
bootstrap-cell-bits (first-bignum) ;
|
|
|
|
|
|
|
|
: bootstrap-most-positive-fixnum ( -- n )
|
|
|
|
bootstrap-first-bignum 1- ;
|
|
|
|
|
|
|
|
: bootstrap-most-negative-fixnum ( -- n )
|
|
|
|
bootstrap-first-bignum neg ;
|
|
|
|
|
2008-06-29 03:12:44 -04:00
|
|
|
: bootstrap-max-array-capacity ( -- n )
|
|
|
|
bootstrap-cell-bits (max-array-capacity) ;
|
|
|
|
|
2008-03-08 03:51:26 -05:00
|
|
|
M: bignum >integer
|
|
|
|
dup most-negative-fixnum most-positive-fixnum between?
|
|
|
|
[ >fixnum ] when ;
|
|
|
|
|
2008-02-22 00:47:06 -05:00
|
|
|
M: real >integer
|
|
|
|
dup most-negative-fixnum most-positive-fixnum between?
|
|
|
|
[ >fixnum ] [ >bignum ] if ;
|
2008-09-17 23:18:08 -04:00
|
|
|
|
|
|
|
UNION: immediate fixnum POSTPONE: f ;
|