steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

faster generic arithmetic, messing around with inference

cvs
Slava Pestov 2005-01-16 22:58:28 +00:00
parent 8247cc5ff4
commit b5801f45dd
31 changed files with 230 additions and 253 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
library/bootstrap/boot-stage2.factor
View File

@ -42,6 +42,7 @@ USE: namespaces
[ [
"/library/generic/generic.factor" "/library/generic/generic.factor"
"/library/generic/object.factor" "/library/generic/object.factor"
"/library/generic/null.factor"
"/library/generic/builtin.factor" "/library/generic/builtin.factor"
"/library/generic/predicate.factor" "/library/generic/predicate.factor"
"/library/generic/union.factor" "/library/generic/union.factor"

3
library/bootstrap/boot.factor
View File

@ -72,16 +72,15 @@ USE: hashtables
"traits" [ "generic" ] search "traits" [ "generic" ] search
"delegate" [ "generic" ] search "delegate" [ "generic" ] search
"object" [ "generic" ] search
vocabularies get [ "generic" off ] bind vocabularies get [ "generic" off ] bind
reveal
reveal reveal
reveal reveal
"/library/generic/generic.factor" parse-resource append, "/library/generic/generic.factor" parse-resource append,
"/library/generic/object.factor" parse-resource append, "/library/generic/object.factor" parse-resource append,
"/library/generic/null.factor" parse-resource append,
"/library/generic/builtin.factor" parse-resource append, "/library/generic/builtin.factor" parse-resource append,
"/library/generic/predicate.factor" parse-resource append, "/library/generic/predicate.factor" parse-resource append,
"/library/generic/union.factor" parse-resource append, "/library/generic/union.factor" parse-resource append,

13
library/bootstrap/image.factor
View File

@ -82,22 +82,15 @@ SYMBOL: boot-quot
: tag ( cell -- tag ) tag-mask bitand ; : tag ( cell -- tag ) tag-mask bitand ;
: fixnum-tag BIN: 000 ; inline : fixnum-tag BIN: 000 ; inline
: bignum-tag BIN: 001 ; inline
: cons-tag BIN: 010 ; inline : cons-tag BIN: 010 ; inline
: object-tag BIN: 011 ; inline : object-tag BIN: 011 ; inline
: ratio-tag BIN: 100 ; inline
: complex-tag BIN: 101 ; inline
: f-type 6 ; inline : f-type 6 ; inline
: t-type 7 ; inline : t-type 7 ; inline
: array-type 8 ; inline : array-type 8 ; inline
: bignum-type 9 ; inline
: float-type 10 ; inline
: vector-type 11 ; inline : vector-type 11 ; inline
: string-type 12 ; inline : string-type 12 ; inline
: sbuf-type 13 ; inline
: port-type 14 ; inline
: dll-type 15 ; inline
: alien-type 16 ; inline
: word-type 17 ; inline : word-type 17 ; inline
: immediate ( x tag -- tagged ) swap tag-bits shift bitor ; : immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
@ -155,8 +148,8 @@ M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
M: bignum ' ( bignum -- tagged ) M: bignum ' ( bignum -- tagged )
#! This can only emit 0, -1 and 1. #! This can only emit 0, -1 and 1.
object-tag here-as >r bignum-tag here-as >r
bignum-type >header emit bignum-tag >header emit
[ [
[[ 0 [ 1 0 ] ]] [[ 0 [ 1 0 ] ]]
[[ -1 [ 2 1 1 ] ]] [[ -1 [ 2 1 1 ] ]]

4
library/compiler/x86/assembler.factor
View File

@ -251,6 +251,10 @@ GENERIC: SUB ( dst src -- )
M: integer SUB HEX: 81 BIN: 101 immediate-8/32 ; M: integer SUB HEX: 81 BIN: 101 immediate-8/32 ;
M: operand SUB HEX: 29 2-operand ; M: operand SUB HEX: 29 2-operand ;
GENERIC: AND ( dst src -- )
M: integer AND HEX: 81 BIN: 100 immediate-8/32 ;
M: operand AND HEX: 21 2-operand ;
: IMUL ( dst src -- ) : IMUL ( dst src -- )
HEX: 0f compile-byte HEX: af 2-operand ; HEX: 0f compile-byte HEX: af 2-operand ;

19
library/compiler/x86/fixnum.factor
View File

@ -145,3 +145,22 @@ USE: math-internals
] "generator" set-word-property ] "generator" set-word-property
\ fixnum/mod [ \ fixnum/mod self ] "infer" set-word-property \ fixnum/mod [ \ fixnum/mod self ] "infer" set-word-property
\ arithmetic-type [
drop
ECX DS>
EAX [ ECX -4 ] MOV
EAX BIN: 111 AND
EDX [ ECX ] MOV
EDX BIN: 111 AND
EAX EDX CMP
0 JE fixup >r
\ arithmetic-type compile-call
0 JMP fixup
compiled-offset r> patch
EAX 3 SHL
PUSH-DS
compiled-offset swap patch
] "generator" set-word-property
\ arithmetic-type [ \ arithmetic-type self ] "infer" set-word-property

7
library/generic/builtin.factor
View File

@ -54,10 +54,13 @@ builtin 50 "priority" set-word-property
builtin [ 2drop t ] "class<" set-word-property builtin [ 2drop t ] "class<" set-word-property
: builtin-predicate ( type# symbol -- ) : builtin-predicate ( type# symbol -- )
over f type = [ #! We call search here because we have to know if the symbol
#! is t or f, and cannot compare type numbers or symbol
#! identity during bootstrapping.
dup "f" [ "syntax" ] search = [
nip [ not ] "predicate" set-word-property nip [ not ] "predicate" set-word-property
] [ ] [
over t type = [ dup "t" [ "syntax" ] search = [
nip [ ] "predicate" set-word-property nip [ ] "predicate" set-word-property
] [ ] [
dup predicate-word dup predicate-word

12
library/generic/generic.factor
View File

@ -190,16 +190,8 @@ SYMBOL: object
: class-and ( class class -- class ) : class-and ( class class -- class )
#! Return a class that is a subclass of both, or raise an #! Return a class that is a subclass of both, or raise an
#! error if this is impossible. #! error if this is impossible.
over builtin-supertypes swap builtin-supertypes swap builtin-supertypes
over builtin-supertypes intersection lookup-union ;
intersection [
nip lookup-union
] [
[
word-name , " and " , word-name ,
" do not intersect" ,
] make-string throw
] ?ifte ;
: define-promise ( class -- ) : define-promise ( class -- )
#! A promise is a word that has no effect during #! A promise is a word that has no effect during

39
library/generic/null.factor Normal file
View File

@ -0,0 +1,39 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2005 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: generic
USE: kernel
USE: words
! Null metaclass with no instances.
SYMBOL: null
null [ drop [ ] ] "builtin-supertypes" set-word-property
null [ 2drop 2drop ] "add-method" set-word-property
null [ drop f ] "predicate" set-word-property
null 100 "priority" set-word-property
null [ 2drop t ] "class<" set-word-property
null null define-class

22
library/inference/branches.factor
View File

@ -154,19 +154,14 @@ SYMBOL: cloned
] extend ; ] extend ;
: (infer-branches) ( branchlist -- list ) : (infer-branches) ( branchlist -- list )
#! The branchlist is a list of pairs: #! The branchlist is a list of pairs: [[ value typeprop ]]
#! [[ value typeprop ]]
#! value is either a literal or computed instance; typeprop #! value is either a literal or computed instance; typeprop
#! is a pair [[ value class ]] indicating a type propagation #! is a pair [[ value class ]] indicating a type propagation
#! for the given branch. #! for the given branch.
[ [
[ [
inferring-base-case get 0 > [ branches-can-fail? [
[ [ infer-branch , ] [ [ drop ] when ] catch
infer-branch ,
] [
[ drop ] when
] catch
] [ ] [
infer-branch , infer-branch ,
] ifte ] ifte
@ -184,7 +179,7 @@ SYMBOL: cloned
#! parameter is a vector. #! parameter is a vector.
(infer-branches) dup unify-effects unify-dataflow ; (infer-branches) dup unify-effects unify-dataflow ;
: (with-block) ( label quot -- ) : (with-block) ( label quot -- node )
#! Call a quotation in a new namespace, and transfer #! Call a quotation in a new namespace, and transfer
#! inference state from the outer scope. #! inference state from the outer scope.
swap >r [ swap >r [
@ -192,8 +187,8 @@ SYMBOL: cloned
call call
d-in get meta-d get meta-r get get-dataflow d-in get meta-d get meta-r get get-dataflow
] with-scope ] with-scope
r> swap #label dataflow, [ node-label set ] bind r> swap #label dataflow, [ node-label set ] extend >r
meta-r set meta-d set d-in set ; meta-r set meta-d set d-in set r> ;
: boolean-value? ( value -- ? ) : boolean-value? ( value -- ? )
#! Return if the value's boolean valuation is known. #! Return if the value's boolean valuation is known.
@ -208,7 +203,8 @@ SYMBOL: cloned
value-class \ f = not ; value-class \ f = not ;
: static-branch? ( value -- ? ) : static-branch? ( value -- ? )
boolean-value? branches-can-fail? not and ; drop f ;
! boolean-value? branches-can-fail? not and ;
: static-ifte ( true false -- ) : static-ifte ( true false -- )
#! If the branch taken is statically known, just infer #! If the branch taken is statically known, just infer
@ -217,7 +213,7 @@ SYMBOL: cloned
gensym [ gensym [
dup value-recursion recursive-state set dup value-recursion recursive-state set
literal-value infer-quot literal-value infer-quot
] (with-block) ; ] (with-block) drop ;
: dynamic-ifte ( true false -- ) : dynamic-ifte ( true false -- )
#! If branch taken is computed, infer along both paths and #! If branch taken is computed, infer along both paths and

8
library/inference/inference.factor
View File

@ -39,13 +39,13 @@ USE: hashtables
USE: generic USE: generic
USE: prettyprint USE: prettyprint
: max-recursion 1 ; : max-recursion 0 ;
! This variable takes a value from 0 up to max-recursion. ! This variable takes a value from 0 up to max-recursion.
SYMBOL: inferring-base-case SYMBOL: inferring-base-case
: branches-can-fail? ( -- ? ) : branches-can-fail? ( -- ? )
inferring-base-case get max-recursion >= ; inferring-base-case get max-recursion > ;
! Word properties that affect inference: ! Word properties that affect inference:
! - infer-effect -- must be set. controls number of inputs ! - infer-effect -- must be set. controls number of inputs
@ -149,6 +149,10 @@ M: literal set-value-class ( class value -- )
#! After inference is finished, collect information. #! After inference is finished, collect information.
uncons >r (present-effect) r> (present-effect) 2list ; uncons >r (present-effect) r> (present-effect) 2list ;
: simple-effect ( [[ d-in meta-d ]] -- [[ in# out# ]] )
#! After inference is finished, collect information.
uncons vector-length >r vector-length r> cons ;
: effect ( -- [[ d-in meta-d ]] ) : effect ( -- [[ d-in meta-d ]] )
d-in get meta-d get cons ; d-in get meta-d get cons ;

2
library/inference/stack.factor
View File

@ -48,7 +48,7 @@ USE: words
#! Partially evaluate a word. #! Partially evaluate a word.
f over dup f over dup
"infer-effect" word-property "infer-effect" word-property
[ drop host-word ] with-dataflow ; [ host-word ] with-dataflow ;
\ drop [ \ drop partial-eval ] "infer" set-word-property \ drop [ \ drop partial-eval ] "infer" set-word-property
\ dup [ \ dup partial-eval ] "infer" set-word-property \ dup [ \ dup partial-eval ] "infer" set-word-property

48
library/inference/words.factor
View File

@ -40,15 +40,15 @@ USE: hashtables
USE: parser USE: parser
USE: prettyprint USE: prettyprint
: with-dataflow ( param op [ intypes outtypes ] quot -- ) : with-dataflow ( param op [[ in# out# ]] quot -- )
#! Take input parameters, execute quotation, take output #! Take input parameters, execute quotation, take output
#! parameters, add node. The quotation is called with the #! parameters, add node. The quotation is called with the
#! stack effect. #! stack effect.
>r dup car ensure-d >r dup car ensure-d
>r dataflow, r> r> rot >r dataflow, r> r> rot
[ pick car swap dataflow-inputs ] keep [ pick car swap [ length 0 node-inputs ] bind ] keep
pick 2slip cdr car swap pick >r >r nip call r> r> cdr car swap
dataflow-outputs ; inline [ length 0 node-outputs ] bind ; inline
: consume-d ( typelist -- ) : consume-d ( typelist -- )
[ pop-d 2drop ] each ; [ pop-d 2drop ] each ;
@ -57,6 +57,7 @@ USE: prettyprint
[ <computed> push-d ] each ; [ <computed> push-d ] each ;
: (consume/produce) ( param op effect ) : (consume/produce) ( param op effect )
dup >r -rot r>
[ unswons consume-d car produce-d ] with-dataflow ; [ unswons consume-d car produce-d ] with-dataflow ;
: consume/produce ( word [ in-types out-types ] -- ) : consume/produce ( word [ in-types out-types ] -- )
@ -78,7 +79,7 @@ USE: prettyprint
: no-effect ( word -- ) : no-effect ( word -- )
"Unknown stack effect: " swap word-name cat2 throw ; "Unknown stack effect: " swap word-name cat2 throw ;
: with-block ( word label quot -- ) : with-block ( word label quot -- node )
#! Execute a quotation with the word on the stack, and add #! Execute a quotation with the word on the stack, and add
#! its dataflow contribution to a new block node in the IR. #! its dataflow contribution to a new block node in the IR.
over [ over [
@ -91,7 +92,7 @@ USE: prettyprint
: recursive? ( word -- ? ) : recursive? ( word -- ? )
dup word-parameter tree-contains? ; dup word-parameter tree-contains? ;
: inline-compound ( word -- effect ) : inline-compound ( word -- effect node )
#! Infer the stack effect of a compound word in the current #! Infer the stack effect of a compound word in the current
#! inferencer instance. If the word in question is recursive #! inferencer instance. If the word in question is recursive
#! we infer its stack effect inside a new block. #! we infer its stack effect inside a new block.
@ -102,7 +103,7 @@ USE: prettyprint
#! instance. #! instance.
[ [
recursive-state get init-inference recursive-state get init-inference
dup dup inline-compound present-effect dup dup inline-compound drop present-effect
[ "infer-effect" set-word-property ] keep [ "infer-effect" set-word-property ] keep
] with-scope consume/produce ; ] with-scope consume/produce ;
@ -111,7 +112,7 @@ GENERIC: (apply-word)
M: compound (apply-word) ( word -- ) M: compound (apply-word) ( word -- )
#! Infer a compound word's stack effect. #! Infer a compound word's stack effect.
dup "inline" word-property [ dup "inline" word-property [
inline-compound drop inline-compound 2drop
] [ ] [
infer-compound infer-compound
] ifte ; ] ifte ;
@ -139,13 +140,6 @@ M: symbol (apply-word) ( word -- )
] when ] when
] when ; ] when ;
: decompose ( x y -- [[ d-in meta-d ]] )
#! Return a stack effect such that x*effect = y.
uncons >r swap uncons >r
over vector-length over vector-length -
swap vector-head nip
r> vector-append r> cons ;
: with-recursion ( quot -- ) : with-recursion ( quot -- )
[ [
inferring-base-case inc inferring-base-case inc
@ -155,15 +149,14 @@ M: symbol (apply-word) ( word -- )
rethrow rethrow
] catch ; ] catch ;
: base-case ( word -- [[ d-in meta-d ]] ) : base-case ( word label -- )
[ [
[ over inline-compound [
copy-inference drop
inline-compound [ #call-label ] [ #call ] ?ifte
] with-scope effect swap decompose node-op set
present-effect node-param set
>r [ #call-label ] [ #call ] ?ifte r> ] bind
(consume/produce)
] with-recursion ; ] with-recursion ;
: no-base-case ( word -- ) : no-base-case ( word -- )
@ -177,11 +170,9 @@ M: symbol (apply-word) ( word -- )
drop no-base-case drop no-base-case
] [ ] [
inferring-base-case get max-recursion = [ inferring-base-case get max-recursion = [
over base-case base-case
] [ ] [
[ [ drop inline-compound 2drop ] with-recursion
drop inline-compound drop
] with-recursion
] ifte ] ifte
] ifte ; ] ifte ;
@ -204,12 +195,13 @@ M: symbol (apply-word) ( word -- )
drop pop-d dup drop pop-d dup
value-recursion recursive-state set value-recursion recursive-state set
literal-value infer-quot literal-value infer-quot
] with-block ; ] with-block drop ;
\ call [ infer-call ] "infer" set-word-property \ call [ infer-call ] "infer" set-word-property
! These hacks will go away soon ! These hacks will go away soon
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-property \ * [ [ number number ] [ number ] ] "infer-effect" set-word-property
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-property
\ undefined-method t "terminator" set-word-property \ undefined-method t "terminator" set-word-property
\ not-a-number t "terminator" set-word-property \ not-a-number t "terminator" set-word-property

9
library/kernel.factor
View File

@ -71,9 +71,16 @@ M: object = eq? ;
: xor ( a b -- a^b ) dup not swap ? ; inline : xor ( a b -- a^b ) dup not swap ? ; inline
IN: syntax IN: syntax
BUILTIN: f 6
! The canonical t is a heap-allocated dummy object. It is always
! the first in the image.
BUILTIN: t 7 BUILTIN: t 7
! In the runtime, the canonical f is represented as a null
! pointer with tag 3. So
! f address . ==> 3
BUILTIN: f 9
IN: kernel IN: kernel
UNION: boolean f t ; UNION: boolean f t ;
COMPLEMENT: general-t f COMPLEMENT: general-t f

8
library/math/math.factor
View File

@ -2,7 +2,7 @@
! $Id$ ! $Id$
! !
! Copyright (C) 2003, 2004 Slava Pestov. ! Copyright (C) 2003, 2005 Slava Pestov.
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met: ! modification, are permitted provided that the following conditions are met:
@ -58,16 +58,16 @@ GENERIC: bitnot ( n -- n )
! Math types ! Math types
BUILTIN: fixnum 0 BUILTIN: fixnum 0
BUILTIN: bignum 9 BUILTIN: bignum 1
UNION: integer fixnum bignum ; UNION: integer fixnum bignum ;
BUILTIN: ratio 4 BUILTIN: ratio 4
UNION: rational integer ratio ; UNION: rational integer ratio ;
BUILTIN: float 10 BUILTIN: float 5
UNION: real rational float ; UNION: real rational float ;
BUILTIN: complex 5 BUILTIN: complex 6
UNION: number real complex ; UNION: number real complex ;
M: real hashcode ( n -- n ) >fixnum ; M: real hashcode ( n -- n ) >fixnum ;

102
library/test/compiler/generic.factor
View File

@ -6,107 +6,31 @@ USE: math
USE: kernel USE: kernel
USE: words USE: words
: single-combination-test GENERIC: single-combination-test
{
[ drop ] M: object single-combination-test drop ;
[ drop ] M: f single-combination-test nip ;
[ drop ]
[ drop ] \ single-combination-test compile
[ drop ]
[ drop ]
[ nip ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
} single-combination ; compiled
[ 2 3 ] [ 2 3 t single-combination-test ] unit-test [ 2 3 ] [ 2 3 t single-combination-test ] unit-test
[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test [ 2 3 ] [ 2 3 4 single-combination-test ] unit-test
[ 2 f ] [ 2 3 f single-combination-test ] unit-test [ 2 f ] [ 2 3 f single-combination-test ] unit-test
: single-combination-literal-test
4 {
[ drop ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
[ nip ]
} single-combination ; compiled
[ ] [ single-combination-literal-test ] unit-test
: single-combination-test-alt
{
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ nip ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
[ drop ]
} single-combination ; compiled
[ 5 ] [ 2 3 4 single-combination-test-alt + ] unit-test
[ 7/2 ] [ 2 3 3/2 single-combination-test-alt + ] unit-test
DEFER: single-combination-test-2 DEFER: single-combination-test-2
: single-combination-test-4 : single-combination-test-4
not single-combination-test-2 ; dup [ single-combination-test-2 ] when ;
: single-combination-test-3 : single-combination-test-3
drop 3 ; drop 3 ;
: single-combination-test-2 GENERIC: single-combination-test-2
{ M: object single-combination-test-2 single-combination-test-3 ;
[ single-combination-test-3 ] M: f single-combination-test-2 single-combination-test-4 ;
[ single-combination-test-3 ]
[ single-combination-test-3 ] \ single-combination-test-2 compile
[ single-combination-test-3 ]
[ single-combination-test-3 ]
[ single-combination-test-3 ]
[ single-combination-test-4 ]
[ single-combination-test-3 ]
[ single-combination-test-3 ]
[ single-combination-test-3 ]
[ single-combination-test-3 ]
[ single-combination-test-3 ]
[ single-combination-test-3 ]
[ single-combination-test-3 ]
[ single-combination-test-3 ]
[ single-combination-test-3 ]
[ single-combination-test-3 ]
} single-combination ;
[ 3 ] [ t single-combination-test-2 ] unit-test [ 3 ] [ t single-combination-test-2 ] unit-test
[ 3 ] [ 3 single-combination-test-2 ] unit-test [ 3 ] [ 3 single-combination-test-2 ] unit-test
[ 3 ] [ f single-combination-test-2 ] unit-test [ f ] [ f single-combination-test-2 ] unit-test

2
library/test/generic.factor
View File

@ -133,7 +133,7 @@ M: very-funny gooey sq ;
[ fixnum ] [ fixnum fixnum class-and ] unit-test [ fixnum ] [ fixnum fixnum class-and ] unit-test
[ fixnum ] [ fixnum integer class-and ] unit-test [ fixnum ] [ fixnum integer class-and ] unit-test
[ fixnum ] [ integer fixnum class-and ] unit-test [ fixnum ] [ integer fixnum class-and ] unit-test
[ vector fixnum class-and ] unit-test-fails [ null ] [ vector fixnum class-and ] unit-test
[ integer ] [ fixnum bignum class-or ] unit-test [ integer ] [ fixnum bignum class-or ] unit-test
[ integer ] [ fixnum integer class-or ] unit-test [ integer ] [ fixnum integer class-or ] unit-test
[ rational ] [ ratio integer class-or ] unit-test [ rational ] [ ratio integer class-or ] unit-test

10
library/test/inference.factor
View File

@ -223,8 +223,8 @@ SYMBOL: sym-test
! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
[ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test
[ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test ! [ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test
[ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test ! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test
[ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test ! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test
!
[ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test ! [ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test

3
library/test/math/complex.factor
View File

@ -3,6 +3,9 @@ USE: kernel
USE: math USE: math
USE: test USE: test
[ 1 #{ 0 1 }# rect> ] unit-test-fails
[ #{ 0 1 }# 1 rect> ] unit-test-fails
[ f ] [ #{ 5 12.5 }# 5 ] [ = ] test-word [ f ] [ #{ 5 12.5 }# 5 ] [ = ] test-word
[ t ] [ #{ 1.0 2.0 }# #{ 1 2 }# ] [ = ] test-word [ t ] [ #{ 1.0 2.0 }# #{ 1 2 }# ] [ = ] test-word
[ f ] [ #{ 1.0 2.3 }# #{ 1 2 }# ] [ = ] test-word [ f ] [ #{ 1.0 2.3 }# #{ 1 2 }# ] [ = ] test-word

18
native/arithmetic.c
View File

@ -5,8 +5,8 @@ void primitive_arithmetic_type(void)
CELL obj1 = dpeek(); CELL obj1 = dpeek();
CELL obj2 = get(ds - CELLS); CELL obj2 = get(ds - CELLS);
CELL type1 = type_of(obj1); CELL type1 = TAG(obj1);
CELL type2 = type_of(obj2); CELL type2 = TAG(obj2);
CELL type; CELL type;
@ -16,10 +16,10 @@ void primitive_arithmetic_type(void)
switch(type1) switch(type1)
{ {
case BIGNUM_TYPE: case BIGNUM_TYPE:
put(ds - CELLS,tag_object(to_bignum(obj2))); put(ds - CELLS,tag_bignum(to_bignum(obj2)));
break; break;
case FLOAT_TYPE: case FLOAT_TYPE:
put(ds - CELLS,tag_object(make_float(to_float((obj2))))); put(ds - CELLS,tag_float(to_float((obj2))));
break; break;
} }
type = type1; type = type1;
@ -28,11 +28,11 @@ void primitive_arithmetic_type(void)
switch(type1) switch(type1)
{ {
case FIXNUM_TYPE: case FIXNUM_TYPE:
drepl(tag_object(to_bignum(obj1))); drepl(tag_bignum(to_bignum(obj1)));
type = type2; type = type2;
break; break;
case FLOAT_TYPE: case FLOAT_TYPE:
put(ds - CELLS,tag_object(make_float(to_float((obj2))))); put(ds - CELLS,tag_float(to_float((obj2))));
type = type1; type = type1;
break; break;
default: default:
@ -48,7 +48,7 @@ void primitive_arithmetic_type(void)
type = type2; type = type2;
break; break;
case FLOAT_TYPE: case FLOAT_TYPE:
put(ds - CELLS,tag_object(make_float(to_float((obj2))))); put(ds - CELLS,tag_float(to_float((obj2))));
type = type1; type = type1;
break; break;
default: default:
@ -62,7 +62,7 @@ void primitive_arithmetic_type(void)
case FIXNUM_TYPE: case FIXNUM_TYPE:
case BIGNUM_TYPE: case BIGNUM_TYPE:
case RATIO_TYPE: case RATIO_TYPE:
drepl(tag_object(make_float(to_float(obj1)))); drepl(tag_float(to_float(obj1)));
type = type2; type = type2;
break; break;
default: default:
@ -88,6 +88,6 @@ void primitive_arithmetic_type(void)
type = type2; type = type2;
break; break;
} }
dpush(tag_fixnum(type)); dpush(tag_fixnum(type));
} }

32
native/bignum.c
View File

@ -53,7 +53,7 @@ CELL to_cell(CELL x)
bignum = to_bignum(x); bignum = to_bignum(x);
if(BIGNUM_NEGATIVE_P(bignum)) if(BIGNUM_NEGATIVE_P(bignum))
{ {
range_error(F,0,tag_object(bignum),FIXNUM_MAX); range_error(F,0,tag_bignum(bignum),FIXNUM_MAX);
return -1; return -1;
} }
else else
@ -100,7 +100,7 @@ F_ARRAY* to_bignum(CELL tagged)
void primitive_to_bignum(void) void primitive_to_bignum(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(to_bignum(dpeek()))); drepl(tag_bignum(to_bignum(dpeek())));
} }
void primitive_bignum_eq(void) void primitive_bignum_eq(void)
@ -119,33 +119,33 @@ void primitive_bignum_eq(void)
void primitive_bignum_add(void) void primitive_bignum_add(void)
{ {
GC_AND_POP_BIGNUMS(x,y); GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_add(x,y))); dpush(tag_bignum(s48_bignum_add(x,y)));
} }
void primitive_bignum_subtract(void) void primitive_bignum_subtract(void)
{ {
GC_AND_POP_BIGNUMS(x,y); GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_subtract(x,y))); dpush(tag_bignum(s48_bignum_subtract(x,y)));
} }
void primitive_bignum_multiply(void) void primitive_bignum_multiply(void)
{ {
GC_AND_POP_BIGNUMS(x,y); GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_multiply(x,y))); dpush(tag_bignum(s48_bignum_multiply(x,y)));
} }
void primitive_bignum_divint(void) void primitive_bignum_divint(void)
{ {
GC_AND_POP_BIGNUMS(x,y); GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_quotient(x,y))); dpush(tag_bignum(s48_bignum_quotient(x,y)));
} }
void primitive_bignum_divfloat(void) void primitive_bignum_divfloat(void)
{ {
GC_AND_POP_BIGNUMS(x,y); GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(make_float( dpush(tag_float(
s48_bignum_to_double(x) / s48_bignum_to_double(x) /
s48_bignum_to_double(y)))); s48_bignum_to_double(y)));
} }
void primitive_bignum_divmod(void) void primitive_bignum_divmod(void)
@ -153,32 +153,32 @@ void primitive_bignum_divmod(void)
F_ARRAY *q, *r; F_ARRAY *q, *r;
GC_AND_POP_BIGNUMS(x,y); GC_AND_POP_BIGNUMS(x,y);
s48_bignum_divide(x,y,&q,&r); s48_bignum_divide(x,y,&q,&r);
dpush(tag_object(q)); dpush(tag_bignum(q));
dpush(tag_object(r)); dpush(tag_bignum(r));
} }
void primitive_bignum_mod(void) void primitive_bignum_mod(void)
{ {
GC_AND_POP_BIGNUMS(x,y); GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_remainder(x,y))); dpush(tag_bignum(s48_bignum_remainder(x,y)));
} }
void primitive_bignum_and(void) void primitive_bignum_and(void)
{ {
GC_AND_POP_BIGNUMS(x,y); GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_bitwise_and(x,y))); dpush(tag_bignum(s48_bignum_bitwise_and(x,y)));
} }
void primitive_bignum_or(void) void primitive_bignum_or(void)
{ {
GC_AND_POP_BIGNUMS(x,y); GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_bitwise_ior(x,y))); dpush(tag_bignum(s48_bignum_bitwise_ior(x,y)));
} }
void primitive_bignum_xor(void) void primitive_bignum_xor(void)
{ {
GC_AND_POP_BIGNUMS(x,y); GC_AND_POP_BIGNUMS(x,y);
dpush(tag_object(s48_bignum_bitwise_xor(x,y))); dpush(tag_bignum(s48_bignum_bitwise_xor(x,y)));
} }
void primitive_bignum_shift(void) void primitive_bignum_shift(void)
@ -188,7 +188,7 @@ void primitive_bignum_shift(void)
maybe_garbage_collection(); maybe_garbage_collection();
y = to_fixnum(dpop()); y = to_fixnum(dpop());
x = to_bignum(dpop()); x = to_bignum(dpop());
dpush(tag_object(s48_bignum_arithmetic_shift(x,y))); dpush(tag_bignum(s48_bignum_arithmetic_shift(x,y)));
} }
void primitive_bignum_less(void) void primitive_bignum_less(void)
@ -248,7 +248,7 @@ void primitive_bignum_greatereq(void)
void primitive_bignum_not(void) void primitive_bignum_not(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(s48_bignum_bitwise_not( drepl(tag_bignum(s48_bignum_bitwise_not(
untag_bignum(dpeek())))); untag_bignum(dpeek()))));
} }

9
native/bignum.h
View File

@ -13,6 +13,11 @@ INLINE F_ARRAY* untag_bignum(CELL tagged)
return untag_bignum_fast(tagged); return untag_bignum_fast(tagged);
} }
INLINE CELL tag_bignum(F_ARRAY* bignum)
{
return RETAG(bignum,BIGNUM_TYPE);
}
F_FIXNUM to_integer(CELL x); F_FIXNUM to_integer(CELL x);
CELL to_cell(CELL x); CELL to_cell(CELL x);
@ -46,7 +51,7 @@ CELL three_test(void* x, unsigned char r, unsigned char g, unsigned char b);
INLINE CELL tag_integer(F_FIXNUM x) INLINE CELL tag_integer(F_FIXNUM x)
{ {
if(x < FIXNUM_MIN || x > FIXNUM_MAX) if(x < FIXNUM_MIN || x > FIXNUM_MAX)
return tag_object(s48_long_to_bignum(x)); return tag_bignum(s48_long_to_bignum(x));
else else
return tag_fixnum(x); return tag_fixnum(x);
} }
@ -54,7 +59,7 @@ INLINE CELL tag_integer(F_FIXNUM x)
INLINE CELL tag_cell(CELL x) INLINE CELL tag_cell(CELL x)
{ {
if(x > FIXNUM_MAX) if(x > FIXNUM_MAX)
return tag_object(s48_ulong_to_bignum(x)); return tag_bignum(s48_ulong_to_bignum(x));
else else
return tag_fixnum(x); return tag_fixnum(x);
} }

8
native/fixnum.c
View File

@ -17,7 +17,7 @@ F_FIXNUM to_fixnum(CELL tagged)
r = (F_RATIO*)UNTAG(tagged); r = (F_RATIO*)UNTAG(tagged);
x = to_bignum(r->numerator); x = to_bignum(r->numerator);
y = to_bignum(r->denominator); y = to_bignum(r->denominator);
return to_fixnum(tag_object(s48_bignum_quotient(x,y))); return to_fixnum(tag_bignum(s48_bignum_quotient(x,y)));
case FLOAT_TYPE: case FLOAT_TYPE:
f = (F_FLOAT*)UNTAG(tagged); f = (F_FLOAT*)UNTAG(tagged);
return (F_FIXNUM)f->n; return (F_FIXNUM)f->n;
@ -72,7 +72,7 @@ void primitive_fixnum_multiply(void)
box_integer(prod); box_integer(prod);
else else
{ {
dpush(tag_object( dpush(tag_bignum(
s48_bignum_multiply( s48_bignum_multiply(
s48_long_to_bignum(x), s48_long_to_bignum(x),
s48_long_to_bignum(y)))); s48_long_to_bignum(y))));
@ -91,7 +91,7 @@ void primitive_fixnum_divfloat(void)
{ {
F_FIXNUM y = untag_fixnum_fast(dpop()); F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop()); F_FIXNUM x = untag_fixnum_fast(dpop());
dpush(tag_object(make_float((double)x / (double)y))); dpush(tag_float((double)x / (double)y));
} }
void primitive_fixnum_divmod(void) void primitive_fixnum_divmod(void)
@ -166,7 +166,7 @@ void primitive_fixnum_shift(void)
} }
} }
dpush(tag_object(s48_bignum_arithmetic_shift( dpush(tag_bignum(s48_bignum_arithmetic_shift(
s48_long_to_bignum(x),y))); s48_long_to_bignum(x),y)));
} }

36
native/float.c
View File

@ -28,7 +28,7 @@ double to_float(CELL tagged)
void primitive_to_float(void) void primitive_to_float(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(make_float(to_float(dpeek())))); drepl(tag_float(to_float(dpeek())));
} }
void primitive_str_to_float(void) void primitive_str_to_float(void)
@ -45,7 +45,7 @@ void primitive_str_to_float(void)
f = strtod(c_str,&end); f = strtod(c_str,&end);
if(end != c_str + str->capacity) if(end != c_str + str->capacity)
general_error(ERROR_FLOAT_FORMAT,tag_object(str)); general_error(ERROR_FLOAT_FORMAT,tag_object(str));
drepl(tag_object(make_float(f))); drepl(tag_float(f));
} }
void primitive_float_to_str(void) void primitive_float_to_str(void)
@ -74,25 +74,25 @@ void primitive_float_eq(void)
void primitive_float_add(void) void primitive_float_add(void)
{ {
GC_AND_POP_FLOATS(x,y); GC_AND_POP_FLOATS(x,y);
dpush(tag_object(make_float(x + y))); dpush(tag_float(x + y));
} }
void primitive_float_subtract(void) void primitive_float_subtract(void)
{ {
GC_AND_POP_FLOATS(x,y); GC_AND_POP_FLOATS(x,y);
dpush(tag_object(make_float(x - y))); dpush(tag_float(x - y));
} }
void primitive_float_multiply(void) void primitive_float_multiply(void)
{ {
GC_AND_POP_FLOATS(x,y); GC_AND_POP_FLOATS(x,y);
dpush(tag_object(make_float(x * y))); dpush(tag_float(x * y));
} }
void primitive_float_divfloat(void) void primitive_float_divfloat(void)
{ {
GC_AND_POP_FLOATS(x,y); GC_AND_POP_FLOATS(x,y);
dpush(tag_object(make_float(x / y))); dpush(tag_float(x / y));
} }
void primitive_float_less(void) void primitive_float_less(void)
@ -122,19 +122,19 @@ void primitive_float_greatereq(void)
void primitive_facos(void) void primitive_facos(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(make_float(acos(to_float(dpeek()))))); drepl(tag_float(acos(to_float(dpeek()))));
} }
void primitive_fasin(void) void primitive_fasin(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(make_float(asin(to_float(dpeek()))))); drepl(tag_float(asin(to_float(dpeek()))));
} }
void primitive_fatan(void) void primitive_fatan(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(make_float(atan(to_float(dpeek()))))); drepl(tag_float(atan(to_float(dpeek()))));
} }
void primitive_fatan2(void) void primitive_fatan2(void)
@ -143,31 +143,31 @@ void primitive_fatan2(void)
maybe_garbage_collection(); maybe_garbage_collection();
y = to_float(dpop()); y = to_float(dpop());
x = to_float(dpop()); x = to_float(dpop());
dpush(tag_object(make_float(atan2(x,y)))); dpush(tag_float(atan2(x,y)));
} }
void primitive_fcos(void) void primitive_fcos(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(make_float(cos(to_float(dpeek()))))); drepl(tag_float(cos(to_float(dpeek()))));
} }
void primitive_fexp(void) void primitive_fexp(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(make_float(exp(to_float(dpeek()))))); drepl(tag_float(exp(to_float(dpeek()))));
} }
void primitive_fcosh(void) void primitive_fcosh(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(make_float(cosh(to_float(dpeek()))))); drepl(tag_float(cosh(to_float(dpeek()))));
} }
void primitive_flog(void) void primitive_flog(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(make_float(log(to_float(dpeek()))))); drepl(tag_float(log(to_float(dpeek()))));
} }
void primitive_fpow(void) void primitive_fpow(void)
@ -176,23 +176,23 @@ void primitive_fpow(void)
maybe_garbage_collection(); maybe_garbage_collection();
y = to_float(dpop()); y = to_float(dpop());
x = to_float(dpop()); x = to_float(dpop());
dpush(tag_object(make_float(pow(x,y)))); dpush(tag_float(pow(x,y)));
} }
void primitive_fsin(void) void primitive_fsin(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(make_float(sin(to_float(dpeek()))))); drepl(tag_float(sin(to_float(dpeek()))));
} }
void primitive_fsinh(void) void primitive_fsinh(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(make_float(sinh(to_float(dpeek()))))); drepl(tag_float(sinh(to_float(dpeek()))));
} }
void primitive_fsqrt(void) void primitive_fsqrt(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
drepl(tag_object(make_float(sqrt(to_float(dpeek()))))); drepl(tag_float(sqrt(to_float(dpeek()))));
} }

5
native/float.h
View File

@ -21,6 +21,11 @@ INLINE double untag_float(CELL tagged)
return untag_float_fast(tagged); return untag_float_fast(tagged);
} }
INLINE CELL tag_float(double flo)
{
return RETAG(make_float(flo),FLOAT_TYPE);
}
double to_float(CELL tagged); double to_float(CELL tagged);
void primitive_to_float(void); void primitive_to_float(void);
void primitive_str_to_float(void); void primitive_str_to_float(void);

2
native/gc.c
View File

@ -148,5 +148,5 @@ void maybe_garbage_collection(void)
void primitive_gc_time(void) void primitive_gc_time(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
dpush(tag_object(s48_long_long_to_bignum(gc_time))); dpush(tag_bignum(s48_long_long_to_bignum(gc_time)));
} }

2
native/memory.c
View File

@ -116,7 +116,7 @@ void primitive_allot_profiling(void)
void primitive_address(void) void primitive_address(void)
{ {
dpush(tag_object(s48_ulong_to_bignum(dpop()))); dpush(tag_bignum(s48_ulong_to_bignum(dpop())));
} }
void primitive_heap_stats(void) void primitive_heap_stats(void)

4
native/misc.c
View File

@ -44,7 +44,7 @@ int64_t current_millis(void)
void primitive_millis(void) void primitive_millis(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
dpush(tag_object(s48_long_long_to_bignum(current_millis()))); dpush(tag_bignum(s48_long_long_to_bignum(current_millis())));
} }
void primitive_init_random(void) void primitive_init_random(void)
@ -55,7 +55,7 @@ void primitive_init_random(void)
void primitive_random_int(void) void primitive_random_int(void)
{ {
maybe_garbage_collection(); maybe_garbage_collection();
dpush(tag_object(s48_long_to_bignum(rand()))); dpush(tag_bignum(s48_long_to_bignum(rand())));
} }
#ifdef WIN32 #ifdef WIN32

6
native/types.c
View File

@ -20,12 +20,18 @@ CELL object_size(CELL pointer)
case FIXNUM_TYPE: case FIXNUM_TYPE:
size = 0; size = 0;
break; break;
case BIGNUM_TYPE:
size = ASIZE(UNTAG(pointer));
break;
case CONS_TYPE: case CONS_TYPE:
size = sizeof(F_CONS); size = sizeof(F_CONS);
break; break;
case RATIO_TYPE: case RATIO_TYPE:
size = sizeof(F_RATIO); size = sizeof(F_RATIO);
break; break;
case FLOAT_TYPE:
size = sizeof(F_FLOAT);
break;
case COMPLEX_TYPE: case COMPLEX_TYPE:
size = sizeof(F_COMPLEX); size = sizeof(F_COMPLEX);
break; break;

45
native/types.h
View File

@ -6,26 +6,27 @@
/*** Tags ***/ /*** Tags ***/
#define FIXNUM_TYPE 0 #define FIXNUM_TYPE 0
#define BIGNUM_TYPE 1
#define CONS_TYPE 2 #define CONS_TYPE 2
#define OBJECT_TYPE 3 #define OBJECT_TYPE 3
#define RATIO_TYPE 4 #define RATIO_TYPE 4
#define COMPLEX_TYPE 5 #define FLOAT_TYPE 5
#define HEADER_TYPE 6 #define COMPLEX_TYPE 6
#define HEADER_TYPE 7
#define GC_COLLECTED 7 /* See gc.c */ #define GC_COLLECTED 7 /* See gc.c */
/*** Header types ***/ /*** Header types ***/
/* Canonical F object */
#define F_TYPE 6
#define F RETAG(0,OBJECT_TYPE)
/* Canonical T object */ /* Canonical T object */
#define T_TYPE 7 #define T_TYPE 7
CELL T; CELL T;
#define ARRAY_TYPE 8 #define ARRAY_TYPE 8
#define BIGNUM_TYPE 9
#define FLOAT_TYPE 10 /* Canonical F object */
#define F_TYPE 9
#define F RETAG(0,OBJECT_TYPE)
#define VECTOR_TYPE 11 #define VECTOR_TYPE 11
#define STRING_TYPE 12 #define STRING_TYPE 12
#define SBUF_TYPE 13 #define SBUF_TYPE 13
@ -48,18 +49,9 @@ INLINE CELL tag_header(CELL cell)
return RETAG(cell << TAG_BITS,OBJECT_TYPE); return RETAG(cell << TAG_BITS,OBJECT_TYPE);
} }
#define HEADER_DEBUG
INLINE CELL untag_header(CELL cell) INLINE CELL untag_header(CELL cell)
{ {
CELL type = cell >> TAG_BITS; return cell >> TAG_BITS;
#ifdef HEADER_DEBUG
if(!headerp(cell))
critical_error("header type check",cell);
if(type <= HEADER_TYPE)
critical_error("header invariant check",cell);
#endif
return type;
} }
INLINE CELL tag_object(void* cell) INLINE CELL tag_object(void* cell)
@ -69,7 +61,10 @@ INLINE CELL tag_object(void* cell)
INLINE CELL object_type(CELL tagged) INLINE CELL object_type(CELL tagged)
{ {
return untag_header(get(UNTAG(tagged))); if(tagged == F)
return F_TYPE;
else
return untag_header(get(UNTAG(tagged)));
} }
INLINE void type_check(CELL type, CELL tagged) INLINE void type_check(CELL type, CELL tagged)
@ -79,11 +74,6 @@ INLINE void type_check(CELL type, CELL tagged)
if(TAG(tagged) == type) if(TAG(tagged) == type)
return; return;
} }
else if(tagged == F)
{
if(type == F_TYPE)
return;
}
else if(TAG(tagged) == OBJECT_TYPE else if(TAG(tagged) == OBJECT_TYPE
&& object_type(tagged) == type) && object_type(tagged) == type)
{ {
@ -102,12 +92,7 @@ INLINE CELL type_of(CELL tagged)
{ {
CELL tag = TAG(tagged); CELL tag = TAG(tagged);
if(tag == OBJECT_TYPE) if(tag == OBJECT_TYPE)
{ return object_type(tagged);
if(tagged == F)
return F_TYPE;
else
return untag_header(get(UNTAG(tagged)));
}
else else
return tag; return tag;
} }

2
native/unix/file.c
View File

@ -43,7 +43,7 @@ void primitive_stat(void)
{ {
CELL dirp = tag_boolean(S_ISDIR(sb.st_mode)); CELL dirp = tag_boolean(S_ISDIR(sb.st_mode));
CELL mode = tag_fixnum(sb.st_mode & ~S_IFMT); CELL mode = tag_fixnum(sb.st_mode & ~S_IFMT);
CELL size = tag_object(s48_long_long_to_bignum(sb.st_size)); CELL size = tag_bignum(s48_long_long_to_bignum(sb.st_size));
CELL mtime = tag_integer(sb.st_mtime); CELL mtime = tag_integer(sb.st_mtime);
dpush(cons( dpush(cons(
dirp, dirp,

2
native/win32/file.c
View File

@ -60,7 +60,7 @@ void primitive_stat(void)
else else
{ {
CELL dirp = tag_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); CELL dirp = tag_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
CELL size = tag_object(s48_long_long_to_bignum( CELL size = tag_bignum(s48_long_long_to_bignum(
(int64_t)st.nFileSizeLow | (int64_t)st.nFileSizeHigh << 32)); (int64_t)st.nFileSizeLow | (int64_t)st.nFileSizeHigh << 32));
CELL mtime = tag_integer((int) CELL mtime = tag_integer((int)
((*(int64_t*)&st.ftLastWriteTime - EPOCH_OFFSET) / 10000000)); ((*(int64_t*)&st.ftLastWriteTime - EPOCH_OFFSET) / 10000000));