From f56615cec0a0d44ab8450d5c811e3d474f9d9cf3 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 15:58:18 -0500
Subject: [PATCH 01/24] add an X-sequence mixin class for each specialized
array type to span X-array, X-vector, and direct-X-array
---
basis/specialized-arrays/direct/functor/functor.factor | 3 +++
basis/specialized-arrays/functor/functor.factor | 5 +++++
basis/specialized-vectors/functor/functor.factor | 3 +++
3 files changed, 11 insertions(+)
diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor
index b49dfa35e4..89d1b5423d 100755
--- a/basis/specialized-arrays/direct/functor/functor.factor
+++ b/basis/specialized-arrays/direct/functor/functor.factor
@@ -8,6 +8,7 @@ IN: specialized-arrays.direct.functor
FUNCTOR: define-direct-array ( T -- )
A' IS ${T}-array
+S IS ${T}-sequence
>A' IS >${T}-array
<A'> IS <${A'}>
A'{ IS ${A'}{
@@ -24,6 +25,8 @@ TUPLE: A
{ underlying c-ptr read-only }
{ length fixnum read-only } ;
+INSTANCE: A S
+
: <A> ( alien len -- direct-array ) A boa ; inline
M: A length length>> ;
M: A nth-unsafe underlying>> NTH call ;
diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor
index 06b9aef17d..a8d8d677ec 100644
--- a/basis/specialized-arrays/functor/functor.factor
+++ b/basis/specialized-arrays/functor/functor.factor
@@ -16,6 +16,7 @@ M: bad-byte-array-length summary
FUNCTOR: define-array ( T -- )
A DEFINES-CLASS ${T}-array
+S DEFINES-CLASS ${T}-sequence
<A> DEFINES <${A}>
(A) DEFINES (${A})
>A DEFINES >${A}
@@ -27,10 +28,14 @@ SET-NTH [ T dup c-setter array-accessor ]
WHERE
+MIXIN: S
+
TUPLE: A
{ length array-capacity read-only }
{ underlying byte-array read-only } ;
+INSTANCE: A S
+
: <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline
: (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline
diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor
index 08c44cd197..48c480b4d1 100644
--- a/basis/specialized-vectors/functor/functor.factor
+++ b/basis/specialized-vectors/functor/functor.factor
@@ -10,6 +10,7 @@ FUNCTOR: define-vector ( T -- )
V DEFINES-CLASS ${T}-vector
A IS ${T}-array
+S IS ${T}-sequence
<A> IS <${A}>
>V DEFERS >${V}
@@ -19,6 +20,8 @@ WHERE
V A <A> vectors.functor:define-vector
+INSTANCE: V S
+
M: V contract 2drop ;
M: V byte-length underlying>> byte-length ;
From 182963b9c49d2c0546c5a87e7d57b9bdb535d924 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 17:19:26 -0500
Subject: [PATCH 02/24] add missing use to classes.struct tests
---
extra/classes/struct/struct-tests.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor
index 51df207003..5da1714803 100644
--- a/extra/classes/struct/struct-tests.factor
+++ b/extra/classes/struct/struct-tests.factor
@@ -1,9 +1,9 @@
! (c)Joe Groff bsd license
USING: accessors alien.c-types alien.libraries
alien.structs.fields alien.syntax classes.struct combinators
-destructors io.pathnames io.streams.string kernel libc literals math
-multiline namespaces prettyprint prettyprint.config see system
-tools.test ;
+destructors io.encodings.utf8 io.pathnames io.streams.string
+kernel libc literals math multiline namespaces prettyprint
+prettyprint.config see system tools.test ;
IN: classes.struct.tests
<<
From 79787f6259a8861055ed1de71f28660781729956 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 17:56:01 -0500
Subject: [PATCH 03/24] associate specialized-arrays vocabs with c-types; add
words for requiring vocabs and constructing arrays by C type
---
basis/alien/c-types/c-types.factor | 96 ++++++++++++++++++-
.../direct/functor/functor.factor | 8 +-
.../specialized-arrays/functor/functor.factor | 9 +-
.../functor/functor.factor | 3 +-
4 files changed, 108 insertions(+), 8 deletions(-)
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 2eba6a2b9e..65f663e7b6 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser
cpu.architecture alien alien.accessors alien.strings quotations
layouts system compiler.units io io.files io.encodings.binary
io.streams.memory accessors combinators effects continuations fry
-classes ;
+classes vocabs vocabs.loader ;
IN: alien.c-types
DEFER: <int>
@@ -27,7 +27,12 @@ TUPLE: c-type < abstract-c-type
boxer
unboxer
{ rep initial: int-rep }
-stack-align? ;
+stack-align?
+array-class
+array-constructor
+direct-array-class
+direct-array-constructor
+sequence-mixin-class ;
: <c-type> ( -- type )
\ c-type new ;
@@ -71,6 +76,48 @@ M: string c-type ( name -- type )
] ?if
] if ;
+: ?require-word ( word/pair -- )
+ dup word? [ drop ] [ first require ] ?if ;
+
+GENERIC: require-c-type-arrays ( c-type -- )
+
+M: object require-c-type-arrays
+ drop ;
+
+M: c-type require-c-type-arrays
+ [ array-class>> ?require-word ]
+ [ sequence-mixin-class>> ?require-word ]
+ [ direct-array-class>> ?require-word ] tri ;
+
+M: string require-c-type-arrays
+ c-type require-c-type-arrays ;
+
+M: array require-c-type-arrays
+ first c-type require-c-type-arrays ;
+
+GENERIC: c-type-array-constructor ( c-type -- word ) foldable
+
+M: string c-type-array-constructor
+ c-type c-type-array-constructor ;
+M: array c-type-array-constructor
+ first c-type c-type-array-constructor ;
+M: c-type c-type-array-constructor
+ array-constructor>> ;
+
+GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable
+
+M: string c-type-direct-array-constructor
+ c-type c-type-array-constructor ;
+M: array c-type-direct-array-constructor
+ first c-type c-type-direct-array-constructor ;
+M: c-type c-type-direct-array-constructor
+ direct-array-constructor>> ;
+
+: <c-type-array> ( len c-type -- array )
+ c-type-array-constructor execute( len -- array ) ; inline
+: <c-type-direct-array> ( len c-type -- array )
+ c-type-direct-array-constructor execute( len -- array ) ; inline
+
GENERIC: c-type-class ( name -- class )
M: abstract-c-type c-type-class class>> ;
@@ -293,6 +340,36 @@ M: long-long-type box-return ( type -- )
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
+: ?lookup ( vocab word -- word/pair )
+ over vocab [ swap lookup ] [ 2array ] if ;
+
+: set-array-class* ( c-type vocab-stem type-stem -- c-type )
+ {
+ [
+ [ "specialized-arrays." prepend ]
+ [ "-array" append ] bi* ?lookup >>array-class
+ ]
+ [
+ [ "specialized-arrays." prepend ]
+ [ "<" "-array>" surround ] bi* ?lookup >>array-constructor
+ ]
+ [
+ [ "specialized-arrays." prepend ]
+ [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class
+ ]
+ [
+ [ "specialized-arrays.direct." prepend ]
+ [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class
+ ]
+ [
+ [ "specialized-arrays.direct." prepend ]
+ [ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
+ ]
+ } 2cleave ;
+
+: set-array-class ( c-type stem -- c-type )
+ dup set-array-class* ;
+
CONSTANT: primitive-types
{
"char" "uchar"
@@ -315,6 +392,7 @@ CONSTANT: primitive-types
[ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"alien_offset" >>unboxer
+ "alien" "void*" set-array-class*
"void*" define-primitive-type
<long-long-type>
@@ -326,6 +404,7 @@ CONSTANT: primitive-types
8 >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
+ "longlong" set-array-class
"longlong" define-primitive-type
<long-long-type>
@@ -337,6 +416,7 @@ CONSTANT: primitive-types
8 >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
+ "ulonglong" set-array-class
"ulonglong" define-primitive-type
<c-type>
@@ -348,6 +428,7 @@ CONSTANT: primitive-types
bootstrap-cell >>align
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
+ "long" set-array-class
"long" define-primitive-type
<c-type>
@@ -359,6 +440,7 @@ CONSTANT: primitive-types
bootstrap-cell >>align
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
+ "ulong" set-array-class
"ulong" define-primitive-type
<c-type>
@@ -370,6 +452,7 @@ CONSTANT: primitive-types
4 >>align
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
+ "int" set-array-class
"int" define-primitive-type
<c-type>
@@ -381,6 +464,7 @@ CONSTANT: primitive-types
4 >>align
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
+ "uint" set-array-class
"uint" define-primitive-type
<c-type>
@@ -392,6 +476,7 @@ CONSTANT: primitive-types
2 >>align
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
+ "short" set-array-class
"short" define-primitive-type
<c-type>
@@ -403,6 +488,7 @@ CONSTANT: primitive-types
2 >>align
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
+ "ushort" set-array-class
"ushort" define-primitive-type
<c-type>
@@ -414,6 +500,7 @@ CONSTANT: primitive-types
1 >>align
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
+ "char" set-array-class
"char" define-primitive-type
<c-type>
@@ -425,6 +512,7 @@ CONSTANT: primitive-types
1 >>align
"box_unsigned_1" >>boxer
"to_cell" >>unboxer
+ "uchar" set-array-class
"uchar" define-primitive-type
<c-type>
@@ -434,6 +522,7 @@ CONSTANT: primitive-types
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
+ "bool" set-array-class
"bool" define-primitive-type
<c-type>
@@ -447,6 +536,7 @@ CONSTANT: primitive-types
"to_float" >>unboxer
single-float-rep >>rep
[ >float ] >>unboxer-quot
+ "float" set-array-class
"float" define-primitive-type
<c-type>
@@ -460,9 +550,11 @@ CONSTANT: primitive-types
"to_double" >>unboxer
double-float-rep >>rep
[ >float ] >>unboxer-quot
+ "double" set-array-class
"double" define-primitive-type
"long" "ptrdiff_t" typedef
"long" "intptr_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit
+
diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor
index 89d1b5423d..4b80940153 100755
--- a/basis/specialized-arrays/direct/functor/functor.factor
+++ b/basis/specialized-arrays/direct/functor/functor.factor
@@ -25,8 +25,6 @@ TUPLE: A
{ underlying c-ptr read-only }
{ length fixnum read-only } ;
-INSTANCE: A S
-
: <A> ( alien len -- direct-array ) A boa ; inline
M: A length length>> ;
M: A nth-unsafe underlying>> NTH call ;
@@ -41,5 +39,11 @@ M: A >pprint-sequence ;
M: A pprint* pprint-object ;
INSTANCE: A sequence
+INSTANCE: A S
+
+T c-type
+ \ A >>direct-array-class
+ \ <A> >>direct-array-constructor
+ drop
;FUNCTOR
diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor
index a8d8d677ec..3341a909d2 100644
--- a/basis/specialized-arrays/functor/functor.factor
+++ b/basis/specialized-arrays/functor/functor.factor
@@ -34,8 +34,6 @@ TUPLE: A
{ length array-capacity read-only }
{ underlying byte-array read-only } ;
-INSTANCE: A S
-
: <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline
: (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline
@@ -78,7 +76,14 @@ M: A pprint* pprint-object ;
SYNTAX: A{ \ } [ >A ] parse-literal ;
INSTANCE: A sequence
+INSTANCE: A S
A T c-type-boxed-class specialize-vector-words
+T c-type
+ \ A >>array-class
+ \ <A> >>array-constructor
+ \ S >>sequence-mixin-class
+ drop
+
;FUNCTOR
diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor
index 48c480b4d1..27bba3f9a6 100644
--- a/basis/specialized-vectors/functor/functor.factor
+++ b/basis/specialized-vectors/functor/functor.factor
@@ -20,8 +20,6 @@ WHERE
V A <A> vectors.functor:define-vector
-INSTANCE: V S
-
M: V contract 2drop ;
M: V byte-length underlying>> byte-length ;
@@ -35,5 +33,6 @@ M: V pprint* pprint-object ;
SYNTAX: V{ \ } [ >V ] parse-literal ;
INSTANCE: V growable
+INSTANCE: V S
;FUNCTOR
From 59cdec755a298e454729fc28e653dc327b468c81 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 18:24:49 -0500
Subject: [PATCH 04/24] throw a better error if <c-type*-array> is called when
specialized array vocab isn't loaded. fix <c-type-direct-array>
---
basis/alien/c-types/c-types.factor | 19 +++++++++++++------
1 file changed, 13 insertions(+), 6 deletions(-)
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 65f663e7b6..675bc56503 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -95,6 +95,8 @@ M: string require-c-type-arrays
M: array require-c-type-arrays
first c-type require-c-type-arrays ;
+ERROR: specialized-array-vocab-not-loaded vocab word ;
+
GENERIC: c-type-array-constructor ( c-type -- word ) foldable
M: string c-type-array-constructor
@@ -102,21 +104,26 @@ M: string c-type-array-constructor
M: array c-type-array-constructor
first c-type c-type-array-constructor ;
M: c-type c-type-array-constructor
- array-constructor>> ;
+ array-constructor>> dup word?
+ [ first2 specialized-array-vocab-not-loaded ] unless ;
GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable
M: string c-type-direct-array-constructor
- c-type c-type-array-constructor ;
+ c-type c-type-direct-array-constructor ;
M: array c-type-direct-array-constructor
first c-type c-type-direct-array-constructor ;
M: c-type c-type-direct-array-constructor
- direct-array-constructor>> ;
+ direct-array-constructor>> dup word?
+ [ first2 specialized-array-vocab-not-loaded ] unless ;
-: <c-type-array> ( len c-type -- array )
+GENERIC: <c-type-array> ( len c-type -- array )
+M: object <c-type-array>
c-type-array-constructor execute( len -- array ) ; inline
-: <c-type-direct-array> ( len c-type -- array )
- c-type-direct-array-constructor execute( len -- array ) ; inline
+
+GENERIC: <c-type-direct-array> ( alien len c-type -- array )
+M: object <c-type-direct-array>
+ c-type-direct-array-constructor execute( alien len -- array ) ; inline
GENERIC: c-type-class ( name -- class )
From 005107973f43952b5b52173c2621ad4121dac064 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 18:51:56 -0500
Subject: [PATCH 05/24] docs for require-c-type-arrays, <c-type-array>,
<c-type-direct-array>
---
basis/alien/arrays/arrays-docs.factor | 7 ++++++-
basis/alien/c-types/c-types-docs.factor | 17 ++++++++++++++++-
2 files changed, 22 insertions(+), 2 deletions(-)
diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor
index c5efe1e030..e8ebe1824d 100644
--- a/basis/alien/arrays/arrays-docs.factor
+++ b/basis/alien/arrays/arrays-docs.factor
@@ -4,4 +4,9 @@ USING: help.syntax help.markup byte-arrays alien.c-types ;
ARTICLE: "c-arrays" "C arrays"
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
$nl
-"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;
+"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
+$nl
+"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:"
+{ $subsection require-c-type-arrays }
+{ $subsection <c-type-array> }
+{ $subsection <c-type-direct-array> } ;
diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor
index c9c1ecd0e5..f5f9e004c4 100644
--- a/basis/alien/c-types/c-types-docs.factor
+++ b/basis/alien/c-types/c-types-docs.factor
@@ -1,7 +1,7 @@
IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private
byte-arrays math strings hashtables alien.syntax alien.strings sequences
-io.encodings.string debugger destructors ;
+io.encodings.string debugger destructors vocabs.loader ;
HELP: <c-type>
{ $values { "type" hashtable } }
@@ -128,6 +128,21 @@ HELP: malloc-string
}
} ;
+HELP: require-c-type-arrays
+{ $values { "c-type" "a C type" } }
+{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link <c-type-array> } " or " { $link <c-type-direct-array> } " vocabularies." }
+{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ;
+
+HELP: <c-type-array>
+{ $values { "len" integer } { "c-type" "a C type" } { "array" "a specialized array" } }
+{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } "." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ;
+
+HELP: <c-type-direct-array>
+{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
+{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
+{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ;
+
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
From f4acf22433091f159483488204b7a231c682fa3a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 18:54:15 -0500
Subject: [PATCH 06/24] specialized-arrays.direct: define byte-length on direct
arrays
---
basis/specialized-arrays/direct/functor/functor.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor
index 4b80940153..37978b6dfa 100755
--- a/basis/specialized-arrays/direct/functor/functor.factor
+++ b/basis/specialized-arrays/direct/functor/functor.factor
@@ -32,6 +32,8 @@ M: A set-nth-unsafe underlying>> SET-NTH call ;
M: A like drop dup A instance? [ >A' ] unless ;
M: A new-sequence drop <A'> ;
+M: A byte-length length>> T heap-size * ;
+
M: A pprint-delims drop \ A'{ \ } ;
M: A >pprint-sequence ;
From d42edd4e3b016d2059d270152f041edfe10e66f2 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 19:04:29 -0500
Subject: [PATCH 07/24] byte-length method for classes.struct STRUCTs
---
extra/classes/struct/struct-tests.factor | 1 +
extra/classes/struct/struct.factor | 10 +++++++++-
2 files changed, 10 insertions(+), 1 deletion(-)
diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor
index 5da1714803..272b8eb129 100644
--- a/extra/classes/struct/struct-tests.factor
+++ b/extra/classes/struct/struct-tests.factor
@@ -30,6 +30,7 @@ STRUCT: struct-test-bar
{ foo struct-test-foo } ;
[ 12 ] [ struct-test-foo heap-size ] unit-test
+[ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
[ 16 ] [ struct-test-bar heap-size ] unit-test
[ 123 ] [ struct-test-foo <struct> y>> ] unit-test
[ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor
index 51df296f1a..7d4eed80af 100644
--- a/extra/classes/struct/struct.factor
+++ b/extra/classes/struct/struct.factor
@@ -94,6 +94,10 @@ M: struct-class writer-quot
[ \ struct-slot-values create-method-in ]
[ struct-slot-values-quot ] bi define ;
+: (define-byte-length-method) ( class -- )
+ [ \ byte-length create-method-in ]
+ [ heap-size \ drop swap [ ] 2sequence ] bi define ;
+
! Struct as c-type
: slot>field ( slot -- field )
@@ -172,6 +176,10 @@ M: struct-class heap-size
over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
] each ;
+: (struct-methods) ( class -- )
+ [ (define-struct-slot-values-method) ]
+ [ (define-byte-length-method) ] bi ;
+
: (struct-word-props) ( class slots size align -- )
[
[ "struct-slots" set-word-prop ]
@@ -181,7 +189,7 @@ M: struct-class heap-size
[ "struct-align" set-word-prop ] tri-curry*
[ tri ] 3curry
[ dup struct-prototype "prototype" set-word-prop ]
- [ (define-struct-slot-values-method) ] tri ;
+ [ (struct-methods) ] tri ;
: check-struct-slots ( slots -- )
[ c-type>> c-type drop ] each ;
From 7b2c9df34128398610161d90efaeff4b4b49415d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 25 Aug 2009 19:33:35 -0500
Subject: [PATCH 08/24] cpu.ppc.assembler: fix FMR and FMR. opcodes
---
.../cpu/ppc/assembler/assembler-tests.factor | 223 +++++++++---------
basis/cpu/ppc/assembler/assembler.factor | 4 +-
2 files changed, 115 insertions(+), 112 deletions(-)
diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor
index 6ee1c84558..8e412c4c83 100644
--- a/basis/cpu/ppc/assembler/assembler-tests.factor
+++ b/basis/cpu/ppc/assembler/assembler-tests.factor
@@ -1,117 +1,120 @@
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
-make vocabs sequences ;
+make vocabs sequences byte-arrays.hex ;
FROM: cpu.ppc.assembler => B ;
IN: cpu.ppc.assembler.tests
: test-assembler ( expected quot -- )
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
-B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler
-B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler
-B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler
-B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler
-B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler
-B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler
-B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler
-B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler
-B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler
-B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler
-B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler
-B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler
-B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler
-B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler
-B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler
-B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
-B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler
-B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler
-B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler
-B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler
-B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler
-B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler
-B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler
-B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler
-B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler
-B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler
-B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler
-B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler
-B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler
-B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
-B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler
-B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler
-B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler
-B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
-B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler
-B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler
-B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler
-B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler
-B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler
-B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler
-B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler
-B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler
-B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler
-B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
-B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
-B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler
-B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler
-B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler
-B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler
-B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
-B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
-B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler
-B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler
-B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler
-B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler
-B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler
-B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler
-B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler
-B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler
-B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler
-B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler
-B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler
-B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler
-B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler
-B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler
-B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler
+HEX{ 38 22 00 03 } [ 1 2 3 ADDI ] test-assembler
+HEX{ 3c 22 00 03 } [ 1 2 3 ADDIS ] test-assembler
+HEX{ 30 22 00 03 } [ 1 2 3 ADDIC ] test-assembler
+HEX{ 34 22 00 03 } [ 1 2 3 ADDIC. ] test-assembler
+HEX{ 38 40 00 01 } [ 1 2 LI ] test-assembler
+HEX{ 3c 40 00 01 } [ 1 2 LIS ] test-assembler
+HEX{ 38 22 ff fd } [ 1 2 3 SUBI ] test-assembler
+HEX{ 1c 22 00 03 } [ 1 2 3 MULI ] test-assembler
+HEX{ 7c 22 1a 14 } [ 1 2 3 ADD ] test-assembler
+HEX{ 7c 22 1a 15 } [ 1 2 3 ADD. ] test-assembler
+HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
+HEX{ 7c 22 1e 15 } [ 1 2 3 ADDO. ] test-assembler
+HEX{ 7c 22 18 14 } [ 1 2 3 ADDC ] test-assembler
+HEX{ 7c 22 18 15 } [ 1 2 3 ADDC. ] test-assembler
+HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
+HEX{ 7c 22 1c 15 } [ 1 2 3 ADDCO. ] test-assembler
+HEX{ 7c 22 19 14 } [ 1 2 3 ADDE ] test-assembler
+HEX{ 7c 41 18 38 } [ 1 2 3 AND ] test-assembler
+HEX{ 7c 41 18 39 } [ 1 2 3 AND. ] test-assembler
+HEX{ 7c 22 1b d6 } [ 1 2 3 DIVW ] test-assembler
+HEX{ 7c 22 1b 96 } [ 1 2 3 DIVWU ] test-assembler
+HEX{ 7c 41 1a 38 } [ 1 2 3 EQV ] test-assembler
+HEX{ 7c 41 1b b8 } [ 1 2 3 NAND ] test-assembler
+HEX{ 7c 41 18 f8 } [ 1 2 3 NOR ] test-assembler
+HEX{ 7c 41 10 f8 } [ 1 2 NOT ] test-assembler
+HEX{ 60 41 00 03 } [ 1 2 3 ORI ] test-assembler
+HEX{ 64 41 00 03 } [ 1 2 3 ORIS ] test-assembler
+HEX{ 7c 41 1b 78 } [ 1 2 3 OR ] test-assembler
+HEX{ 7c 41 13 78 } [ 1 2 MR ] test-assembler
+HEX{ 7c 22 18 96 } [ 1 2 3 MULHW ] test-assembler
+HEX{ 1c 22 00 03 } [ 1 2 3 MULLI ] test-assembler
+HEX{ 7c 22 18 16 } [ 1 2 3 MULHWU ] test-assembler
+HEX{ 7c 22 19 d6 } [ 1 2 3 MULLW ] test-assembler
+HEX{ 7c 41 18 30 } [ 1 2 3 SLW ] test-assembler
+HEX{ 7c 41 1e 30 } [ 1 2 3 SRAW ] test-assembler
+HEX{ 7c 41 1c 30 } [ 1 2 3 SRW ] test-assembler
+HEX{ 7c 41 1e 70 } [ 1 2 3 SRAWI ] test-assembler
+HEX{ 7c 22 18 50 } [ 1 2 3 SUBF ] test-assembler
+HEX{ 7c 22 18 10 } [ 1 2 3 SUBFC ] test-assembler
+HEX{ 7c 22 19 10 } [ 1 2 3 SUBFE ] test-assembler
+HEX{ 7c 41 07 74 } [ 1 2 EXTSB ] test-assembler
+HEX{ 68 41 00 03 } [ 1 2 3 XORI ] test-assembler
+HEX{ 7c 41 1a 78 } [ 1 2 3 XOR ] test-assembler
+HEX{ 7c 22 00 d0 } [ 1 2 NEG ] test-assembler
+HEX{ 2c 22 00 03 } [ 1 2 3 CMPI ] test-assembler
+HEX{ 28 22 00 03 } [ 1 2 3 CMPLI ] test-assembler
+HEX{ 7c 41 18 00 } [ 1 2 3 CMP ] test-assembler
+HEX{ 54 22 19 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
+HEX{ 54 22 18 38 } [ 1 2 3 SLWI ] test-assembler
+HEX{ 54 22 e8 fe } [ 1 2 3 SRWI ] test-assembler
+HEX{ 88 22 00 03 } [ 1 2 3 LBZ ] test-assembler
+HEX{ 8c 22 00 03 } [ 1 2 3 LBZU ] test-assembler
+HEX{ a8 22 00 03 } [ 1 2 3 LHA ] test-assembler
+HEX{ ac 22 00 03 } [ 1 2 3 LHAU ] test-assembler
+HEX{ a0 22 00 03 } [ 1 2 3 LHZ ] test-assembler
+HEX{ a4 22 00 03 } [ 1 2 3 LHZU ] test-assembler
+HEX{ 80 22 00 03 } [ 1 2 3 LWZ ] test-assembler
+HEX{ 84 22 00 03 } [ 1 2 3 LWZU ] test-assembler
+HEX{ 7c 41 18 ae } [ 1 2 3 LBZX ] test-assembler
+HEX{ 7c 41 18 ee } [ 1 2 3 LBZUX ] test-assembler
+HEX{ 7c 41 1a ae } [ 1 2 3 LHAX ] test-assembler
+HEX{ 7c 41 1a ee } [ 1 2 3 LHAUX ] test-assembler
+HEX{ 7c 41 1a 2e } [ 1 2 3 LHZX ] test-assembler
+HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler
+HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler
+HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler
+HEX{ 48 00 00 01 } [ 1 B ] test-assembler
+HEX{ 48 00 00 01 } [ 1 BL ] test-assembler
+HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
+HEX{ 41 81 00 04 } [ 1 BGT ] test-assembler
+HEX{ 40 81 00 04 } [ 1 BLE ] test-assembler
+HEX{ 40 80 00 04 } [ 1 BGE ] test-assembler
+HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
+HEX{ 40 82 00 04 } [ 1 BNE ] test-assembler
+HEX{ 41 82 00 04 } [ 1 BEQ ] test-assembler
+HEX{ 41 83 00 04 } [ 1 BO ] test-assembler
+HEX{ 40 83 00 04 } [ 1 BNO ] test-assembler
+HEX{ 4c 20 00 20 } [ 1 BCLR ] test-assembler
+HEX{ 4e 80 00 20 } [ BLR ] test-assembler
+HEX{ 4e 80 00 21 } [ BLRL ] test-assembler
+HEX{ 4c 20 04 20 } [ 1 BCCTR ] test-assembler
+HEX{ 4e 80 04 20 } [ BCTR ] test-assembler
+HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
+HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
+HEX{ 7c 69 02 a6 } [ 3 MFCTR ] test-assembler
+HEX{ 7c 61 03 a6 } [ 3 MTXER ] test-assembler
+HEX{ 7c 68 03 a6 } [ 3 MTLR ] test-assembler
+HEX{ 7c 69 03 a6 } [ 3 MTCTR ] test-assembler
+HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
+HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
+HEX{ c0 22 00 03 } [ 1 2 3 LFS ] test-assembler
+HEX{ c4 22 00 03 } [ 1 2 3 LFSU ] test-assembler
+HEX{ c8 22 00 03 } [ 1 2 3 LFD ] test-assembler
+HEX{ cc 22 00 03 } [ 1 2 3 LFDU ] test-assembler
+HEX{ d0 22 00 03 } [ 1 2 3 STFS ] test-assembler
+HEX{ d4 22 00 03 } [ 1 2 3 STFSU ] test-assembler
+HEX{ d8 22 00 03 } [ 1 2 3 STFD ] test-assembler
+HEX{ dc 22 00 03 } [ 1 2 3 STFDU ] test-assembler
+HEX{ fc 20 10 90 } [ 1 2 FMR ] test-assembler
+HEX{ fc 40 08 90 } [ 2 1 FMR ] test-assembler
+HEX{ fc 20 10 91 } [ 1 2 FMR. ] test-assembler
+HEX{ fc 40 08 91 } [ 2 1 FMR. ] test-assembler
+HEX{ fc 20 10 1e } [ 1 2 FCTIWZ ] test-assembler
+HEX{ fc 22 18 2a } [ 1 2 3 FADD ] test-assembler
+HEX{ fc 22 18 2b } [ 1 2 3 FADD. ] test-assembler
+HEX{ fc 22 18 28 } [ 1 2 3 FSUB ] test-assembler
+HEX{ fc 22 00 f2 } [ 1 2 3 FMUL ] test-assembler
+HEX{ fc 22 18 24 } [ 1 2 3 FDIV ] test-assembler
+HEX{ fc 20 10 2c } [ 1 2 FSQRT ] test-assembler
+HEX{ fc 41 18 00 } [ 1 2 3 FCMPU ] test-assembler
+HEX{ fc 41 18 40 } [ 1 2 3 FCMPO ] test-assembler
+HEX{ 3c 60 12 34 60 63 56 78 } [ HEX: 12345678 3 LOAD ] test-assembler
diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor
index 2daf3678ce..2362bdc73c 100644
--- a/basis/cpu/ppc/assembler/assembler.factor
+++ b/basis/cpu/ppc/assembler/assembler.factor
@@ -97,8 +97,8 @@ X: XOR 0 316 31
X: XOR. 1 316 31
X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31
-: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ;
-: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
+: FMR ( a s -- ) [ 0 ] 2dip 0 72 63 x-insn ;
+: FMR. ( a s -- ) [ 0 ] 2dip 1 72 63 x-insn ;
: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
From b71e14d89f9e4dc2fd5decde908910fab4c2b864 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 25 Aug 2009 19:33:48 -0500
Subject: [PATCH 09/24] benchmark.raytracer: eliminate -rot usage
---
extra/benchmark/raytracer/raytracer.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor
index 25915404be..de9b80b4ca 100755
--- a/extra/benchmark/raytracer/raytracer.factor
+++ b/extra/benchmark/raytracer/raytracer.factor
@@ -155,7 +155,7 @@ DEFER: create ( level c r -- scene )
] with map ;
: ray-pixel ( scene point -- n )
- ss-grid ray-grid 0.0 -rot
+ ss-grid ray-grid [ 0.0 ] 2dip
[ [ swap cast-ray + ] with each ] with each ;
: pixel-grid ( -- grid )
From 1afd001393724e2c651fda73bdccc4569b07990c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 25 Aug 2009 19:38:48 -0500
Subject: [PATCH 10/24] basis/cpu: eliminate some usages of rot
---
basis/cpu/ppc/assembler/assembler.factor | 12 +++++++-----
basis/cpu/ppc/ppc.factor | 2 +-
basis/cpu/x86/32/32.factor | 6 +++---
basis/cpu/x86/64/64.factor | 11 +++++------
4 files changed, 16 insertions(+), 15 deletions(-)
diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor
index 2362bdc73c..f59f8779ef 100644
--- a/basis/cpu/ppc/assembler/assembler.factor
+++ b/basis/cpu/ppc/assembler/assembler.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces words io.binary math math.order
+USING: kernel namespaces words math math.order locals
cpu.ppc.assembler.backend ;
IN: cpu.ppc.assembler
@@ -189,9 +189,9 @@ MTSPR: LR 8
MTSPR: CTR 9
! Pseudo-instructions
-: LI ( value dst -- ) 0 rot ADDI ; inline
+: LI ( value dst -- ) swap [ 0 ] dip ADDI ; inline
: SUBI ( dst src1 src2 -- ) neg ADDI ; inline
-: LIS ( value dst -- ) 0 rot ADDIS ; inline
+: LIS ( value dst -- ) swap [ 0 ] dip ADDIS ; inline
: SUBIC ( dst src1 src2 -- ) neg ADDIC ; inline
: SUBIC. ( dst src1 src2 -- ) neg ADDIC. ; inline
: NOT ( dst src -- ) dup NOR ; inline
@@ -204,6 +204,8 @@ MTSPR: CTR 9
: (SRWI) ( d a b -- d a b x y ) 32 over - swap 31 ; inline
: SRWI ( d a b -- ) (SRWI) RLWINM ;
: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
-: LOAD32 ( n r -- ) [ w>h/h ] dip tuck LIS dup rot ORI ;
+:: LOAD32 ( n r -- )
+ n -16 shift HEX: 7fff bitand r LIS
+ r r n HEX: 7fff bitand ORI ;
: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index d6674e7097..aec7e85b56 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -62,7 +62,7 @@ M: rs-loc loc-reg drop rs-reg ;
M: ppc %peek loc>operand LWZ ;
M: ppc %replace loc>operand STW ;
-: (%inc) ( n reg -- ) dup rot cells ADDI ; inline
+:: (%inc) ( n reg -- ) reg reg n cells ADDI ; inline
M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index bd03b47302..74312c3718 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -208,13 +208,13 @@ M: x86 %unbox-small-struct ( size -- )
{ 2 [ %unbox-struct-2 ] }
} case ;
-M: x86.32 %unbox-large-struct ( n c-type -- )
+M:: x86.32 %unbox-large-struct ( n c-type -- )
! Alien must be in EAX.
! Compute destination address
- ECX rot stack@ LEA
+ ECX n stack@ LEA
12 [
! Push struct size
- heap-size PUSH
+ c-type heap-size PUSH
! Push destination address
ECX PUSH
! Push source address
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 7c832fe66c..145d4ff677 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -102,13 +102,12 @@ M: x86.64 %unbox-small-struct ( c-type -- )
flatten-value-type [ %unbox-struct-field ] each-index
] with-return-regs ;
-M: x86.64 %unbox-large-struct ( n c-type -- )
+M:: x86.64 %unbox-large-struct ( n c-type -- )
! Source is in param-reg-1
- heap-size
- ! Load destination address
- param-reg-2 rot param@ LEA
- ! Load structure size
- param-reg-3 swap MOV
+ ! Load destination address into param-reg-2
+ param-reg-2 n param@ LEA
+ ! Load structure size into param-reg-3
+ param-reg-3 c-type heap-size MOV
! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ;
From 61c1ed17d982084b144e958524d310e4cdfad5fb Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@oberon.local>
Date: Tue, 25 Aug 2009 19:41:17 -0500
Subject: [PATCH 11/24] basis/compiler/tests/low-level-ir: add ##copy
double-float-rep test
---
basis/compiler/tests/low-level-ir.factor | 13 ++++++++++++-
1 file changed, 12 insertions(+), 1 deletion(-)
diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index ececac3037..e3e2c3344e 100644
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -46,6 +46,17 @@ IN: compiler.tests.low-level-ir
} compile-test-bb
] unit-test
+! ##copy on floats
+[ 1.5 ] [
+ V{
+ T{ ##load-reference f 4 1.5 }
+ T{ ##unbox-float f 1 4 }
+ T{ ##copy f 2 1 double-float-rep }
+ T{ ##box-float f 3 2 }
+ T{ ##copy f 0 3 int-rep }
+ } compile-test-bb
+] unit-test
+
! make sure slot access works when the destination is
! one of the sources
[ t ] [
@@ -138,4 +149,4 @@ USE: multiline
} compile-test-bb
] unit-test
-*/
\ No newline at end of file
+*/
From 8aa9327dccf2686c0e216751102693b85597e3b3 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 19:58:04 -0500
Subject: [PATCH 12/24] support <c-type-array> on complex ffi types
---
basis/alien/c-types/c-types.factor | 9 ++++++---
basis/alien/complex/functor/functor.factor | 22 ++++++++++++++++------
basis/alien/structs/structs.factor | 9 ++++-----
extra/classes/struct/struct.factor | 2 +-
4 files changed, 27 insertions(+), 15 deletions(-)
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 675bc56503..779a5e18de 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -79,12 +79,15 @@ M: string c-type ( name -- type )
: ?require-word ( word/pair -- )
dup word? [ drop ] [ first require ] ?if ;
+MIXIN: array-c-type
+INSTANCE: c-type array-c-type
+
GENERIC: require-c-type-arrays ( c-type -- )
M: object require-c-type-arrays
drop ;
-M: c-type require-c-type-arrays
+M: array-c-type require-c-type-arrays
[ array-class>> ?require-word ]
[ sequence-mixin-class>> ?require-word ]
[ direct-array-class>> ?require-word ] tri ;
@@ -103,7 +106,7 @@ M: string c-type-array-constructor
c-type c-type-array-constructor ;
M: array c-type-array-constructor
first c-type c-type-array-constructor ;
-M: c-type c-type-array-constructor
+M: array-c-type c-type-array-constructor
array-constructor>> dup word?
[ first2 specialized-array-vocab-not-loaded ] unless ;
@@ -113,7 +116,7 @@ M: string c-type-direct-array-constructor
c-type c-type-direct-array-constructor ;
M: array c-type-direct-array-constructor
first c-type c-type-direct-array-constructor ;
-M: c-type c-type-direct-array-constructor
+M: array-c-type c-type-direct-array-constructor
direct-array-constructor>> dup word?
[ first2 specialized-array-vocab-not-loaded ] unless ;
diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor
index 98d412639f..a5580318a9 100644
--- a/basis/alien/complex/functor/functor.factor
+++ b/basis/alien/complex/functor/functor.factor
@@ -1,10 +1,18 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.structs alien.c-types math math.functions sequences
-arrays kernel functors vocabs.parser namespaces accessors
-quotations ;
+USING: alien.structs alien.structs.fields alien.c-types
+math math.functions sequences arrays kernel functors
+vocabs.parser namespaces accessors quotations ;
IN: alien.complex.functor
+TUPLE: complex-c-type < struct-type
+ array-class
+ array-constructor
+ direct-array-class
+ direct-array-constructor
+ sequence-mixin-class ;
+INSTANCE: complex-c-type array-c-type
+
FUNCTOR: define-complex-type ( N T -- )
T-real DEFINES ${T}-real
@@ -23,14 +31,16 @@ WHERE
: *T ( alien -- z )
[ T-real ] [ T-imaginary ] bi rect> ; inline
-T current-vocab
-{ { N "real" } { N "imaginary" } }
-define-struct
+T N c-type-align [ 2 * ] [ ] bi
+T current-vocab N "real" <field-spec>
+T current-vocab N "imaginary" <field-spec> N c-type-align >>offset
+2array complex-c-type (define-struct)
T c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
number >>boxed-class
+T set-array-class
drop
;FUNCTOR
diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index 5c1fb4063b..3d9cae1202 100755
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -35,9 +35,8 @@ M: struct-type stack-size
: c-struct? ( type -- ? ) (c-type) struct-type? ;
-: (define-struct) ( name size align fields -- )
- [ [ align ] keep ] dip
- struct-type new
+: (define-struct) ( name size align fields class -- )
+ [ [ align ] keep ] 2dip new
byte-array >>class
byte-array >>boxed-class
swap >>fields
@@ -55,13 +54,13 @@ M: struct-type stack-size
[ 2drop ] [ make-fields ] 3bi
[ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep
- [ (define-struct) ] keep
+ [ struct-type (define-struct) ] keep
[ define-field ] each ;
: define-union ( name members -- )
[ expand-constants ] map
[ [ heap-size ] [ max ] map-reduce ] keep
- compute-struct-align f (define-struct) ;
+ compute-struct-align f struct-type (define-struct) ;
: offset-of ( field struct -- offset )
c-types get at fields>>
diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor
index 7d4eed80af..e9de2f7e36 100644
--- a/extra/classes/struct/struct.factor
+++ b/extra/classes/struct/struct.factor
@@ -117,7 +117,7 @@ M: struct-class writer-quot
[ "struct-align" word-prop ]
[ struct-slots [ slot>field ] map ]
} cleave
- (define-struct)
+ struct-type (define-struct)
] [
{
[ name>> c-type ]
From a2518377e342a62933366a457f907bb938d6720b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 20:43:48 -0500
Subject: [PATCH 13/24] support <c-type-array> of structs using struct-arrays
---
basis/alien/c-types/c-types.factor | 47 +++++++++-------------
basis/alien/complex/functor/functor.factor | 21 +++-------
basis/alien/structs/structs.factor | 12 +++++-
3 files changed, 37 insertions(+), 43 deletions(-)
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 779a5e18de..4fc8dab9fe 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -21,19 +21,19 @@ TUPLE: abstract-c-type
{ getter callable }
{ setter callable }
size
-align ;
-
-TUPLE: c-type < abstract-c-type
-boxer
-unboxer
-{ rep initial: int-rep }
-stack-align?
+align
array-class
array-constructor
direct-array-class
direct-array-constructor
sequence-mixin-class ;
+TUPLE: c-type < abstract-c-type
+boxer
+unboxer
+{ rep initial: int-rep }
+stack-align? ;
+
: <c-type> ( -- type )
\ c-type new ;
@@ -79,15 +79,12 @@ M: string c-type ( name -- type )
: ?require-word ( word/pair -- )
dup word? [ drop ] [ first require ] ?if ;
-MIXIN: array-c-type
-INSTANCE: c-type array-c-type
-
GENERIC: require-c-type-arrays ( c-type -- )
M: object require-c-type-arrays
drop ;
-M: array-c-type require-c-type-arrays
+M: c-type require-c-type-arrays
[ array-class>> ?require-word ]
[ sequence-mixin-class>> ?require-word ]
[ direct-array-class>> ?require-word ] tri ;
@@ -100,33 +97,29 @@ M: array require-c-type-arrays
ERROR: specialized-array-vocab-not-loaded vocab word ;
-GENERIC: c-type-array-constructor ( c-type -- word ) foldable
-
-M: string c-type-array-constructor
- c-type c-type-array-constructor ;
-M: array c-type-array-constructor
- first c-type c-type-array-constructor ;
-M: array-c-type c-type-array-constructor
+: c-type-array-constructor ( c-type -- word )
array-constructor>> dup word?
- [ first2 specialized-array-vocab-not-loaded ] unless ;
+ [ first2 specialized-array-vocab-not-loaded ] unless ; foldable
-GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable
-
-M: string c-type-direct-array-constructor
- c-type c-type-direct-array-constructor ;
-M: array c-type-direct-array-constructor
- first c-type c-type-direct-array-constructor ;
-M: array-c-type c-type-direct-array-constructor
+: c-type-direct-array-constructor ( c-type -- word )
direct-array-constructor>> dup word?
- [ first2 specialized-array-vocab-not-loaded ] unless ;
+ [ first2 specialized-array-vocab-not-loaded ] unless ; foldable
GENERIC: <c-type-array> ( len c-type -- array )
M: object <c-type-array>
c-type-array-constructor execute( len -- array ) ; inline
+M: string <c-type-array>
+ c-type <c-type-array> ; inline
+M: array <c-type-array>
+ first c-type <c-type-array> ; inline
GENERIC: <c-type-direct-array> ( alien len c-type -- array )
M: object <c-type-direct-array>
c-type-direct-array-constructor execute( alien len -- array ) ; inline
+M: string <c-type-direct-array>
+ c-type <c-type-direct-array> ; inline
+M: array <c-type-direct-array>
+ first c-type <c-type-direct-array> ; inline
GENERIC: c-type-class ( name -- class )
diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor
index a5580318a9..7727546c00 100644
--- a/basis/alien/complex/functor/functor.factor
+++ b/basis/alien/complex/functor/functor.factor
@@ -1,18 +1,10 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.structs alien.structs.fields alien.c-types
-math math.functions sequences arrays kernel functors
-vocabs.parser namespaces accessors quotations ;
+USING: alien.structs alien.c-types math math.functions sequences
+arrays kernel functors vocabs.parser namespaces accessors
+quotations ;
IN: alien.complex.functor
-TUPLE: complex-c-type < struct-type
- array-class
- array-constructor
- direct-array-class
- direct-array-constructor
- sequence-mixin-class ;
-INSTANCE: complex-c-type array-c-type
-
FUNCTOR: define-complex-type ( N T -- )
T-real DEFINES ${T}-real
@@ -31,10 +23,9 @@ WHERE
: *T ( alien -- z )
[ T-real ] [ T-imaginary ] bi rect> ; inline
-T N c-type-align [ 2 * ] [ ] bi
-T current-vocab N "real" <field-spec>
-T current-vocab N "imaginary" <field-spec> N c-type-align >>offset
-2array complex-c-type (define-struct)
+T current-vocab
+{ { N "real" } { N "imaginary" } }
+define-struct
T c-type
<T> 1quotation >>unboxer-quot
diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index 3d9cae1202..d8b2edf394 100755
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -3,7 +3,7 @@
USING: accessors arrays assocs generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc fry
alien.c-types alien.structs.fields cpu.architecture math.order
-quotations byte-arrays ;
+quotations byte-arrays struct-arrays ;
IN: alien.structs
TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
@@ -12,6 +12,16 @@ M: struct-type c-type ;
M: struct-type c-type-stack-align? drop f ;
+M: struct-type <c-type-array> ( len c-type -- array )
+ dup c-type-array-constructor
+ [ execute( len -- array ) ]
+ [ <struct-array> ] ?if ; inline
+
+M: struct-type <c-type-direct-array> ( alien len c-type -- array )
+ dup c-type-direct-array-constructor
+ [ execute( alien len -- array ) ]
+ [ <direct-struct-array> ] ?if ; inline
+
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
From 87c670b785604ecff2cd2493ff9fd328f8cac209 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 20:57:23 -0500
Subject: [PATCH 14/24] no really, support <c-type-array> of structs using
struct-arrays
---
basis/alien/c-types/c-types.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 4fc8dab9fe..9f7ac75558 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -98,12 +98,12 @@ M: array require-c-type-arrays
ERROR: specialized-array-vocab-not-loaded vocab word ;
: c-type-array-constructor ( c-type -- word )
- array-constructor>> dup word?
- [ first2 specialized-array-vocab-not-loaded ] unless ; foldable
+ array-constructor>> dup array?
+ [ first2 specialized-array-vocab-not-loaded ] when ; foldable
: c-type-direct-array-constructor ( c-type -- word )
- direct-array-constructor>> dup word?
- [ first2 specialized-array-vocab-not-loaded ] unless ; foldable
+ direct-array-constructor>> dup array?
+ [ first2 specialized-array-vocab-not-loaded ] when ; foldable
GENERIC: <c-type-array> ( len c-type -- array )
M: object <c-type-array>
From b6bba164e4724233a49eedb2a3b5a26f93e50bf9 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 21:36:25 -0500
Subject: [PATCH 15/24] box array c-types into direct-arrays
---
basis/alien/arrays/arrays.factor | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor
index d793814c28..fbf59e6f11 100755
--- a/basis/alien/arrays/arrays.factor
+++ b/basis/alien/arrays/arrays.factor
@@ -29,7 +29,11 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ;
-M: array c-type-boxer-quot drop [ ] ;
+M: array c-type-boxer-quot
+ unclip
+ [ product ]
+ [ [ require-c-type-arrays ] keep ] bi*
+ [ <c-type-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
From e919e71163988dc54ec986b98407143b6616a0de Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 21:54:19 -0500
Subject: [PATCH 16/24] test array slots in STRUCTs
---
extra/classes/struct/struct-tests.factor | 18 ++++++++++++++++--
1 file changed, 16 insertions(+), 2 deletions(-)
diff --git a/extra/classes/struct/struct-tests.factor b/extra/classes/struct/struct-tests.factor
index 272b8eb129..6c7a4cf35d 100644
--- a/extra/classes/struct/struct-tests.factor
+++ b/extra/classes/struct/struct-tests.factor
@@ -1,9 +1,10 @@
! (c)Joe Groff bsd license
USING: accessors alien.c-types alien.libraries
-alien.structs.fields alien.syntax classes.struct combinators
+alien.structs.fields alien.syntax ascii classes.struct combinators
destructors io.encodings.utf8 io.pathnames io.streams.string
kernel libc literals math multiline namespaces prettyprint
-prettyprint.config see system tools.test ;
+prettyprint.config see sequences specialized-arrays.ushort
+system tools.test ;
IN: classes.struct.tests
<<
@@ -145,3 +146,16 @@ LIBRARY: f-cdecl
FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
+
+STRUCT: struct-test-array-slots
+ { x int }
+ { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
+ { z int } ;
+
+[ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
+
+[ t ] [
+ struct-test-array-slots <struct>
+ [ y>> [ 8 3 ] dip set-nth ]
+ [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
+] unit-test
From b7e29ca8dddb0216050f0cf922f205e2e900e6e2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 25 Aug 2009 22:37:10 -0500
Subject: [PATCH 17/24] cpu.ppc.assembler: LOAD32 assembler macro was busted
---
basis/cpu/ppc/assembler/assembler.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor
index f59f8779ef..dd633f4e9a 100644
--- a/basis/cpu/ppc/assembler/assembler.factor
+++ b/basis/cpu/ppc/assembler/assembler.factor
@@ -205,7 +205,7 @@ MTSPR: CTR 9
: SRWI ( d a b -- ) (SRWI) RLWINM ;
: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
:: LOAD32 ( n r -- )
- n -16 shift HEX: 7fff bitand r LIS
- r r n HEX: 7fff bitand ORI ;
+ n -16 shift HEX: ffff bitand r LIS
+ r r n HEX: ffff bitand ORI ;
: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
From 0df8aadce2c595ab0c3c9efb5215c42628bb76b2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 25 Aug 2009 23:22:15 -0500
Subject: [PATCH 18/24] cpu.x86: use SQRTSD instruction for math.libm:fsqrt
word
---
basis/compiler/cfg/hats/hats.factor | 1 +
.../cfg/instructions/instructions.factor | 3 +++
.../compiler/cfg/intrinsics/float/float.factor | 3 +++
basis/compiler/cfg/intrinsics/intrinsics.factor | 5 +++++
basis/compiler/codegen/codegen.factor | 2 ++
.../propagation/known-words/known-words.factor | 16 +++++++++++-----
basis/cpu/architecture/architecture.factor | 1 +
basis/cpu/x86/32/32.factor | 1 +
basis/cpu/x86/64/64.factor | 1 +
basis/cpu/x86/x86.factor | 1 +
basis/math/libm/libm.factor | 17 -----------------
11 files changed, 29 insertions(+), 22 deletions(-)
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index 04fddbb203..d90745a25e 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -43,6 +43,7 @@ IN: compiler.cfg.hats
: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
+: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 4cf4340bd7..87c6909a9f 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -106,6 +106,7 @@ INSN: ##add-float < ##commutative ;
INSN: ##sub-float < ##binary ;
INSN: ##mul-float < ##commutative ;
INSN: ##div-float < ##binary ;
+INSN: ##sqrt < ##unary ;
! Float/integer conversion
INSN: ##float>integer < ##unary ;
@@ -256,6 +257,7 @@ UNION: output-float-insn
##sub-float
##mul-float
##div-float
+ ##sqrt
##integer>float
##unbox-float
##alien-float
@@ -267,6 +269,7 @@ UNION: input-float-insn
##sub-float
##mul-float
##div-float
+ ##sqrt
##float>integer
##box-float
##set-alien-float
diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor
index 152be80286..9d0af29a15 100644
--- a/basis/compiler/cfg/intrinsics/float/float.factor
+++ b/basis/compiler/cfg/intrinsics/float/float.factor
@@ -15,3 +15,6 @@ IN: compiler.cfg.intrinsics.float
: emit-fixnum>float ( -- )
ds-pop ^^untag-fixnum ^^integer>float ds-push ;
+
+: emit-fsqrt ( -- )
+ ds-pop ^^sqrt ds-push ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 363197c3c0..27d9970a91 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -19,6 +19,7 @@ QUALIFIED: strings.private
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: math.integers.private
+QUALIFIED: math.libm
QUALIFIED: alien.accessors
IN: compiler.cfg.intrinsics
@@ -92,6 +93,9 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
+: enable-fsqrt ( -- )
+ \ math.libm:fsqrt t "intrinsic" set-word-prop ;
+
: enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
@@ -130,6 +134,7 @@ IN: compiler.cfg.intrinsics
{ \ math.private:float= [ drop cc= emit-float-comparison ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
+ { \ math.libm:fsqrt [ drop emit-fsqrt ] }
{ \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] }
{ \ strings.private:string-nth [ drop emit-string-nth ] }
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index d1b5558beb..6395d8644f 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -170,6 +170,8 @@ M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
M: ##div-float generate-insn dst/src1/src2 %div-float ;
+M: ##sqrt generate-insn dst/src %sqrt ;
+
M: ##integer>float generate-insn dst/src %integer>float ;
M: ##float>integer generate-insn dst/src %float>integer ;
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 3a20424e18..2387db3c15 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -2,11 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel effects accessors math math.private
math.integers.private math.partial-dispatch math.intervals
-math.parser math.order math.functions layouts words sequences sequences.private
-arrays assocs classes classes.algebra combinators generic.math
-splitting fry locals classes.tuple alien.accessors
-classes.tuple.private slots.private definitions strings.private
-vectors hashtables generic quotations
+math.parser math.order math.functions math.libm layouts words
+sequences sequences.private arrays assocs classes
+classes.algebra combinators generic.math splitting fry locals
+classes.tuple alien.accessors classes.tuple.private
+slots.private definitions strings.private vectors hashtables
+generic quotations
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
@@ -297,3 +298,8 @@ generic-comparison-ops [
bi
] [ 2drop object-info ] if
] "outputs" set-word-prop
+
+{ facos fasin fatan fatan2 fcos fsin ftan fcosh fsinh ftanh fexp
+flog fpow fsqrt facosh fasinh fatanh } [
+ { float } "default-output-classes" set-word-prop
+] each
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 7bb9caec9b..71200e1ede 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -110,6 +110,7 @@ HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %mul-float cpu ( dst src1 src2 -- )
HOOK: %div-float cpu ( dst src1 src2 -- )
+HOOK: %sqrt cpu ( dst src -- )
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 74312c3718..8808c47995 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -304,6 +304,7 @@ USING: cpu.x86.features cpu.x86.features.private ;
sse2? [
" - yes" print
enable-float-intrinsics
+ enable-fsqrt
[
sse2? [
"This image was built to use SSE2, which your CPU does not support." print
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 145d4ff677..153e2c511b 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -203,6 +203,7 @@ enable-alien-4-intrinsics
! SSE2 is always available on x86-64.
enable-float-intrinsics
+enable-fsqrt
USE: vocabs.loader
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index a6c958083c..f61dd82276 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -203,6 +203,7 @@ M: x86 %add-float nip ADDSD ;
M: x86 %sub-float nip SUBSD ;
M: x86 %mul-float nip MULSD ;
M: x86 %div-float nip DIVSD ;
+M: x86 %sqrt SQRTSD ;
M: x86 %integer>float CVTSI2SD ;
M: x86 %float>integer CVTTSD2SI ;
diff --git a/basis/math/libm/libm.factor b/basis/math/libm/libm.factor
index 96f5f134cc..e2bd2ef6eb 100644
--- a/basis/math/libm/libm.factor
+++ b/basis/math/libm/libm.factor
@@ -5,69 +5,52 @@ IN: math.libm
: facos ( x -- y )
"double" "libm" "acos" { "double" } alien-invoke ;
- inline
: fasin ( x -- y )
"double" "libm" "asin" { "double" } alien-invoke ;
- inline
: fatan ( x -- y )
"double" "libm" "atan" { "double" } alien-invoke ;
- inline
: fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
- inline
: fcos ( x -- y )
"double" "libm" "cos" { "double" } alien-invoke ;
- inline
: fsin ( x -- y )
"double" "libm" "sin" { "double" } alien-invoke ;
- inline
: ftan ( x -- y )
"double" "libm" "tan" { "double" } alien-invoke ;
- inline
: fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ;
- inline
: fsinh ( x -- y )
"double" "libm" "sinh" { "double" } alien-invoke ;
- inline
: ftanh ( x -- y )
"double" "libm" "tanh" { "double" } alien-invoke ;
- inline
: fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ;
- inline
: flog ( x -- y )
"double" "libm" "log" { "double" } alien-invoke ;
- inline
: fpow ( x y -- z )
"double" "libm" "pow" { "double" "double" } alien-invoke ;
- inline
: fsqrt ( x -- y )
"double" "libm" "sqrt" { "double" } alien-invoke ;
- inline
! Windows doesn't have these...
: facosh ( x -- y )
"double" "libm" "acosh" { "double" } alien-invoke ;
- inline
: fasinh ( x -- y )
"double" "libm" "asinh" { "double" } alien-invoke ;
- inline
: fatanh ( x -- y )
"double" "libm" "atanh" { "double" } alien-invoke ;
- inline
From 8d55616d346977da7500b80ecb879b7ce7eb193f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 25 Aug 2009 23:44:01 -0500
Subject: [PATCH 19/24] compiler.cfg.debugger: fix fake-representations so that
low-level-ir tests can pass on x86
---
basis/compiler/cfg/debugger/debugger.factor | 30 +++++++++++----------
1 file changed, 16 insertions(+), 14 deletions(-)
diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 33f87ff1d4..d51aa477c9 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -1,15 +1,16 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io vectors
-classes.tuple accessors prettyprint prettyprint.config assocs
-prettyprint.backend prettyprint.custom prettyprint.sections
-parser compiler.tree.builder compiler.tree.optimizer
-cpu.architecture compiler.cfg.builder compiler.cfg.linearization
-compiler.cfg.registers compiler.cfg.stack-frame
-compiler.cfg.linear-scan compiler.cfg.two-operand
-compiler.cfg.optimizer compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.def-use
-compiler.cfg.rpo compiler.cfg.mr compiler.cfg ;
+arrays hashtables classes.tuple accessors prettyprint
+prettyprint.config assocs prettyprint.backend prettyprint.custom
+prettyprint.sections parser compiler.tree.builder
+compiler.tree.optimizer cpu.architecture compiler.cfg.builder
+compiler.cfg.linearization compiler.cfg.registers
+compiler.cfg.stack-frame compiler.cfg.linear-scan
+compiler.cfg.two-operand compiler.cfg.optimizer
+compiler.cfg.instructions compiler.cfg.utilities
+compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
+compiler.cfg.representations.preferred compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
@@ -73,8 +74,9 @@ M: rs-loc pprint* \ R pprint-loc ;
: fake-representations ( cfg -- )
post-order [
- instructions>>
- [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ]
- map concat
- ] map concat
- [ int-rep ] H{ } map>assoc representations set ;
\ No newline at end of file
+ instructions>> [
+ [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
+ [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
+ bi [ suffix ] when*
+ ] map concat
+ ] map concat >hashtable representations set ;
\ No newline at end of file
From a6c8e91f88b6f24f8954aa41bdf748f3cd059caa Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 23:50:27 -0500
Subject: [PATCH 20/24] fix directory-entries so we can bootstrap again
---
basis/io/directories/unix/unix.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor
index b8b781ec12..a107a46275 100644
--- a/basis/io/directories/unix/unix.factor
+++ b/basis/io/directories/unix/unix.factor
@@ -57,7 +57,7 @@ M: unix find-next-file ( DIR* -- byte-array )
M: unix >directory-entry ( byte-array -- directory-entry )
{
- [ dirent-d_name utf8 alien>string ]
+ [ dirent-d_name underlying>> utf8 alien>string ]
[ dirent-d_type dirent-type>file-type ]
} cleave directory-entry boa ;
From 0ff80a063db6bb13cf903f465acb6d9041c00d89 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 26 Aug 2009 06:58:47 -0500
Subject: [PATCH 21/24] compiler: only run float test in low-level-ir if float
intrinsics enabled; fixes SIGILL on non-sse2 x86 machines
---
basis/compiler/tests/low-level-ir.factor | 25 +++++++++++++-----------
1 file changed, 14 insertions(+), 11 deletions(-)
diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index e3e2c3344e..d67aaef43b 100644
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -3,7 +3,7 @@ compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr
compiler.cfg.registers compiler.codegen compiler.units
cpu.architecture hashtables kernel namespaces sequences
tools.test vectors words layouts literals math arrays
-alien.syntax ;
+alien.syntax math.private ;
IN: compiler.tests.low-level-ir
: compile-cfg ( cfg -- word )
@@ -46,16 +46,19 @@ IN: compiler.tests.low-level-ir
} compile-test-bb
] unit-test
-! ##copy on floats
-[ 1.5 ] [
- V{
- T{ ##load-reference f 4 1.5 }
- T{ ##unbox-float f 1 4 }
- T{ ##copy f 2 1 double-float-rep }
- T{ ##box-float f 3 2 }
- T{ ##copy f 0 3 int-rep }
- } compile-test-bb
-] unit-test
+! ##copy on floats. We can only run this test if float intrinsics
+! are enabled.
+\ float+ "intrinsic" word-prop [
+ [ 1.5 ] [
+ V{
+ T{ ##load-reference f 4 1.5 }
+ T{ ##unbox-float f 1 4 }
+ T{ ##copy f 2 1 double-float-rep }
+ T{ ##box-float f 3 2 }
+ T{ ##copy f 0 3 int-rep }
+ } compile-test-bb
+ ] unit-test
+] when
! make sure slot access works when the destination is
! one of the sources
From 8bf709acd015f7ddcbfb927f6439dd89cb30ceaf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 26 Aug 2009 08:58:00 -0500
Subject: [PATCH 22/24] compiler.cfg.linear-scan: fix unit tests for new
fake-representations
---
.../cfg/linear-scan/linear-scan-tests.factor | 51 ++++++++++++-------
1 file changed, 32 insertions(+), 19 deletions(-)
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index b7a97e75c6..062c62adab 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -656,14 +656,17 @@ V{
T{ ##copy
{ dst 689481 }
{ src 689475 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689482 }
{ src 689474 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689483 }
{ src 689473 }
+ { rep int-rep }
}
T{ ##branch }
} 2 test-bb
@@ -672,14 +675,17 @@ V{
T{ ##copy
{ dst 689481 }
{ src 689473 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689482 }
{ src 689475 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689483 }
{ src 689474 }
+ { rep int-rep }
}
T{ ##branch }
} 3 test-bb
@@ -742,10 +748,12 @@ V{
T{ ##copy
{ dst 689608 }
{ src 689600 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689610 }
{ src 689601 }
+ { rep int-rep }
}
T{ ##branch }
} 2 test-bb
@@ -758,14 +766,17 @@ V{
T{ ##copy
{ dst 689607 }
{ src 689600 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689608 }
{ src 689601 }
+ { rep int-rep }
}
T{ ##copy
{ dst 689610 }
{ src 689609 }
+ { rep int-rep }
}
T{ ##branch }
} 3 test-bb
@@ -816,6 +827,7 @@ V{
T{ ##copy
{ dst 2 }
{ src 1 }
+ { rep int-rep }
}
T{ ##branch }
} 2 test-bb
@@ -828,6 +840,7 @@ V{
T{ ##copy
{ dst 2 }
{ src 3 }
+ { rep int-rep }
}
T{ ##branch }
} 3 test-bb
@@ -1121,7 +1134,7 @@ V{
{ slot 1 }
{ tag 2 }
}
- T{ ##copy { dst 79 } { src 69 } }
+ T{ ##copy { dst 79 } { src 69 } { rep int-rep } }
T{ ##slot-imm
{ dst 85 }
{ obj 62 }
@@ -1169,22 +1182,22 @@ V{
T{ ##peek { dst 114 } { loc D 1 } }
T{ ##peek { dst 116 } { loc D 4 } }
T{ ##peek { dst 119 } { loc R 0 } }
- T{ ##copy { dst 109 } { src 108 } }
- T{ ##copy { dst 111 } { src 110 } }
- T{ ##copy { dst 113 } { src 112 } }
- T{ ##copy { dst 115 } { src 114 } }
- T{ ##copy { dst 117 } { src 116 } }
- T{ ##copy { dst 120 } { src 119 } }
+ T{ ##copy { dst 109 } { src 108 } { rep int-rep } }
+ T{ ##copy { dst 111 } { src 110 } { rep int-rep } }
+ T{ ##copy { dst 113 } { src 112 } { rep int-rep } }
+ T{ ##copy { dst 115 } { src 114 } { rep int-rep } }
+ T{ ##copy { dst 117 } { src 116 } { rep int-rep } }
+ T{ ##copy { dst 120 } { src 119 } { rep int-rep } }
T{ ##branch }
} 3 test-bb
V{
- T{ ##copy { dst 109 } { src 62 } }
- T{ ##copy { dst 111 } { src 61 } }
- T{ ##copy { dst 113 } { src 62 } }
- T{ ##copy { dst 115 } { src 79 } }
- T{ ##copy { dst 117 } { src 64 } }
- T{ ##copy { dst 120 } { src 69 } }
+ T{ ##copy { dst 109 } { src 62 } { rep int-rep } }
+ T{ ##copy { dst 111 } { src 61 } { rep int-rep } }
+ T{ ##copy { dst 113 } { src 62 } { rep int-rep } }
+ T{ ##copy { dst 115 } { src 79 } { rep int-rep } }
+ T{ ##copy { dst 117 } { src 64 } { rep int-rep } }
+ T{ ##copy { dst 120 } { src 69 } { rep int-rep } }
T{ ##branch }
} 4 test-bb
@@ -1306,12 +1319,12 @@ V{
T{ ##peek { dst 162 } { loc D 1 } }
T{ ##peek { dst 164 } { loc D 4 } }
T{ ##peek { dst 167 } { loc R 0 } }
- T{ ##copy { dst 157 } { src 156 } }
- T{ ##copy { dst 159 } { src 158 } }
- T{ ##copy { dst 161 } { src 160 } }
- T{ ##copy { dst 163 } { src 162 } }
- T{ ##copy { dst 165 } { src 164 } }
- T{ ##copy { dst 168 } { src 167 } }
+ T{ ##copy { dst 157 } { src 156 } { rep int-rep } }
+ T{ ##copy { dst 159 } { src 158 } { rep int-rep } }
+ T{ ##copy { dst 161 } { src 160 } { rep int-rep } }
+ T{ ##copy { dst 163 } { src 162 } { rep int-rep } }
+ T{ ##copy { dst 165 } { src 164 } { rep int-rep } }
+ T{ ##copy { dst 168 } { src 167 } { rep int-rep } }
T{ ##branch }
} 4 test-bb
From 75b3bc655a4b182cf846233aca571d9b62ed7f72 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 26 Aug 2009 09:13:30 -0500
Subject: [PATCH 23/24] allow alien.strings:alien>string to take an object with
underlying>> slot
---
core/alien/strings/strings.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor
index c74c325726..ff20b8b033 100644
--- a/core/alien/strings/strings.factor
+++ b/core/alien/strings/strings.factor
@@ -12,6 +12,9 @@ M: c-ptr alien>string
[ <memory-stream> ] [ <decoder> ] bi*
"\0" swap stream-read-until drop ;
+M: object alien>string
+ [ underlying>> ] dip alien>string ;
+
M: f alien>string
drop ;
From 5a298a00fd61cf4a1815f6e1ced1b0e08dbe7ff8 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 26 Aug 2009 09:28:10 -0500
Subject: [PATCH 24/24] windows.ole32 guid functions don't need to box the
byte-arrays themselves anymore
---
basis/windows/ole32/ole32.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor
index d6a08325d9..639a9ba637 100755
--- a/basis/windows/ole32/ole32.factor
+++ b/basis/windows/ole32/ole32.factor
@@ -148,7 +148,7 @@ TUPLE: ole32-error code message ;
[ ]
} 2cleave
- GUID-Data4 8 <direct-uchar-array> {
+ GUID-Data4 {
[ 20 22 0 (guid-byte>guid) ]
[ 22 24 1 (guid-byte>guid) ]
@@ -175,7 +175,7 @@ TUPLE: ole32-error code message ;
[ [ GUID-Data3 ] 4 (guid-section%) "-" % ]
[ ]
} cleave
- GUID-Data4 8 <direct-uchar-array> {
+ GUID-Data4 {
[ 0 (guid-byte%) ]
[ 1 (guid-byte%) "-" % ]
[ 2 (guid-byte%) ]