core/layouts/layouts.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces math words kernel assocs classes
   4 math.order kernel.private ;
   5 IN: layouts
   6
   7 SYMBOL: tag-mask
   8
   9 SYMBOL: num-tags
  10
  11 SYMBOL: tag-bits
  12
  13 SYMBOL: num-types
  14
  15 SYMBOL: tag-numbers
  16
  17 SYMBOL: type-numbers
  18
  19 : tag-number ( class -- n )
  20     tag-numbers get at [ object tag-number ] unless* ;
  21
  22 : type-number ( class -- n )
  23     type-numbers get at ;
  24
  25 : tag-fixnum ( n -- tagged )
  26     tag-bits get shift ;
  27
  28 ! We do this in its own compilation unit so that they can be
  29 ! folded below
  30 <<
  31 : cell ( -- n ) 7 getenv ; foldable
  32
  33 : (first-bignum) ( m -- n ) tag-bits get - 1 - 2^ ; foldable
  34 >>
  35
  36 : cells ( m -- n ) cell * ; inline
  37
  38 : cell-bits ( -- n ) 8 cells ; inline
  39
  40 : bootstrap-cell ( -- n ) \ cell get cell or ; inline
  41
  42 : bootstrap-cells ( m -- n ) bootstrap-cell * ; inline
  43
  44 : bootstrap-cell-bits ( -- n ) 8 bootstrap-cells ; inline
  45
  46 : first-bignum ( -- n )
  47     cell-bits (first-bignum) ; inline
  48
  49 : most-positive-fixnum ( -- n )
  50     first-bignum 1- ; inline
  51
  52 : most-negative-fixnum ( -- n )
  53     first-bignum neg ; inline
  54
  55 : (max-array-capacity) ( b -- n )
  56     5 - 2^ 1- ; inline
  57
  58 : max-array-capacity ( -- n )
  59     cell-bits (max-array-capacity) ; inline
  60
  61 : bootstrap-first-bignum ( -- n )
  62     bootstrap-cell-bits (first-bignum) ;
  63
  64 : bootstrap-most-positive-fixnum ( -- n )
  65     bootstrap-first-bignum 1- ;
  66
  67 : bootstrap-most-negative-fixnum ( -- n )
  68     bootstrap-first-bignum neg ;
  69
  70 : bootstrap-max-array-capacity ( -- n )
  71     bootstrap-cell-bits (max-array-capacity) ;
  72
  73 M: bignum >integer
  74     dup most-negative-fixnum most-positive-fixnum between?
  75     [ >fixnum ] when ;
  76
  77 M: real >integer
  78     dup most-negative-fixnum most-positive-fixnum between?
  79     [ >fixnum ] [ >bignum ] if ;
  80
  81 UNION: immediate fixnum POSTPONE: f ;