classes.struct: make new and boa work on struct-class

diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor
index adb16cab27fc9b17854ce8802cc0570f84d89b06..5fc1a7104b2401e11cd4088faec218dc99420001 100644 (file)
--- a/basis/classes/struct/struct-tests.factor
+++ b/basis/classes/struct/struct-tests.factor
@@ -40,6 +40,8 @@ STRUCT: struct-test-bar
 
 { 12 } [ struct-test-foo heap-size ] unit-test
 { 12 } [ struct-test-foo <struct> byte-length ] unit-test
+{ t } [ [ struct-test-foo new ] { <struct> } inlined? ] unit-test
+{ t } [ [ struct-test-foo boa ] { <struct-boa> } inlined? ] 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/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index 9ec9d0ad9b17c9c5dcf3808fb4128d8f5b1dc8d6..c2be33c344caede1ce7ba11c7600f4a8bd02ab2d 100644 (file)
--- a/basis/classes/struct/struct.factor
+++ b/basis/classes/struct/struct.factor
@@ -5,7 +5,7 @@ USING: accessors alien alien.c-types alien.data alien.parser
 arrays byte-arrays classes classes.parser classes.private
 classes.struct.bit-accessors classes.tuple classes.tuple.parser
 combinators combinators.smart cpu.architecture definitions
-delegate.private functors.backend generalizations generic
+delegate.private effects functors.backend generalizations generic
 generic.parser io kernel kernel.private lexer libc math
 math.order parser quotations sequences slots slots.private
 specialized-arrays stack-checker.dependencies summary vectors
@@ -52,7 +52,8 @@ M: struct >c-ptr
 : memory>struct ( ptr class -- struct )
     ! This is sub-optimal if the class is not literal, but gets
     ! optimized down to efficient code if it is.
-    '[ _ boa ] call( ptr -- struct ) ; inline
+    struct-class check-instance
+    M\ tuple-class boa execute( ptr class -- struct ) ;
 
 : read-struct ( class -- struct )
     [ heap-size read ] [ memory>struct ] bi ;
@@ -134,6 +135,13 @@ M: struct-class boa>object
     [ <struct> ] [ struct-slots ] bi
     [ [ (writer-quot) call( value struct -- ) ] with 2each ] keepd ;
 
+M: struct-class new <struct> ;
+
+M: struct-class boa <struct-boa> ;
+
+M: struct-class boa-effect
+    [ struct-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ;
+
 M: struct-class initial-value* <struct> t ; inline
 
 ! Struct slot accessors

diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index fcecff5a06e461de7cbe340c566f0c64f02ff033..6790139d0a41cda303649c51e289e4616a55275e 100644 (file)
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -1,12 +1,17 @@
 ! Copyright (C) 2008, 2011 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays assocs byte-arrays classes classes.algebra
-classes.tuple classes.tuple.private combinators combinators.short-circuit
-compiler.tree.propagation.info effects generalizations generic generic.single
-growable hash-sets hashtables kernel layouts math math.integers.private
-math.intervals math.order math.partial-dispatch math.private namespaces
-quotations sequences sequences.generalizations sequences.private sets
-sets.private stack-checker stack-checker.dependencies strings vectors words ;
+
+USING: accessors alien.c-types arrays assocs byte-arrays classes
+classes.algebra classes.struct classes.tuple
+classes.tuple.private combinators combinators.short-circuit
+compiler.tree.propagation.info effects generalizations generic
+generic.single growable hash-sets hashtables kernel layouts math
+math.integers.private math.intervals math.order
+math.partial-dispatch math.private namespaces quotations
+sequences sequences.generalizations sequences.private sets
+sets.private stack-checker stack-checker.dependencies strings
+vectors words ;
+
 FROM: math => float ;
 IN: compiler.tree.propagation.transforms
 
@@ -179,16 +184,31 @@ ERROR: bad-partial-eval quot word ;
     ] "custom-inlining" set-word-prop ;
 
 : inline-new ( class -- quot/f )
+    {
+        { [ dup struct-class? ] [
+            dup dup struct-slots add-depends-on-struct-slots
+            '[ _ <struct> ] ] }
+        { [ dup tuple-class? ] [
+            dup tuple-layout
+            [ add-depends-on-tuple-layout ]
+            [ drop all-slots [ initial>> literalize ] [ ] map-as ]
+            [ nip ]
+            2tri
+            '[ @ _ <tuple-boa> ]
+            ] }
+        [ drop f ]
+    } cond ;
+
+\ new [ inline-new ] 1 define-partial-eval
+
+\ memory>struct [
     dup tuple-class? [
         dup tuple-layout
         [ add-depends-on-tuple-layout ]
-        [ drop all-slots [ initial>> literalize ] [ ] map-as ]
-        [ nip ]
-        2tri
+        [ [ "boa-check" word-prop [ ] or ] dip ] 2bi
         '[ @ _ <tuple-boa> ]
-    ] [ drop f ] if ;
-
-\ new [ inline-new ] 1 define-partial-eval
+    ] [ drop f ] if
+] 1 define-partial-eval
 
 \ instance? [
     dup classoid?

diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index c7e65ce4f5d606a20712c3d0783c509433428aac..5f0f48a4766892027b069bde160d01420648ce22 100644 (file)
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -1,11 +1,13 @@
 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes.tuple classes.tuple.private combinators
-combinators.short-circuit continuations generic kernel
-namespaces quotations sequences stack-checker.backend
-stack-checker.dependencies stack-checker.errors
-stack-checker.recursive-state stack-checker.values
-stack-checker.visitor words ;
+
+USING: accessors classes.struct classes.tuple
+classes.tuple.private combinators combinators.short-circuit
+continuations generic kernel namespaces quotations sequences
+stack-checker.backend stack-checker.dependencies
+stack-checker.errors stack-checker.recursive-state
+stack-checker.values stack-checker.visitor words ;
+
 IN: stack-checker.transforms
 
 : call-transformer ( stack quot -- newquot )
@@ -138,14 +140,18 @@ IN: stack-checker.transforms
 
 ! Constructors
 \ boa [
-    dup tuple-class? [
-        dup tuple-layout
-        [ add-depends-on-tuple-layout ]
-        [ [ "boa-check" word-prop [ ] or ] dip ] 2bi
-        '[ @ _ <tuple-boa> ]
-    ] [
-        \ boa time-bomb
-    ] if
+    {
+        { [ dup struct-class? ] [
+            dup dup struct-slots add-depends-on-struct-slots
+            '[ _ <struct-boa> ] ] }
+        { [ dup tuple-class? ] [
+            dup tuple-layout
+            [ add-depends-on-tuple-layout ]
+            [ [ "boa-check" word-prop [ ] or ] dip ] 2bi
+            '[ @ _ <tuple-boa> ]
+            ] }
+        [ \ boa time-bomb ]
+    } cond
 ] 1 define-transform
 
 \ boa t "no-compile" set-word-prop