Constructors experiment

diff --git a/extra/constructors/authors.txt b/extra/constructors/authors.txt
new file mode 100644 (file)
index 0000000..d4f5d6b
--- /dev/null
+++ b/extra/constructors/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file

diff --git a/extra/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor
new file mode 100644 (file)
index 0000000..367f0ad
--- /dev/null
+++ b/extra/constructors/constructors-tests.factor
@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test constructors calendar kernel accessors
+combinators.short-circuit ;
+IN: constructors.tests
+
+TUPLE: stock-spread stock spread timestamp ;
+
+CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
+   now >>timestamp ;
+
+SYMBOL: AAPL
+
+[ t ] [
+    AAPL 1234 <stock-spread>
+    {
+        [ stock>> AAPL eq? ]
+        [ spread>> 1234 = ]
+        [ timestamp>> timestamp? ]
+    } 1&&
+] unit-test
\ No newline at end of file

diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor
new file mode 100644 (file)
index 0000000..6968fd7
--- /dev/null
+++ b/extra/constructors/constructors.factor
@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slots kernel sequences fry accessors parser lexer words
+effects.parser ;
+IN: constructors
+
+! An experiment
+
+: constructor-quot ( class slot-names body -- quot )
+    [ <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ] dip
+    '[ _ new @ @ ] ;
+
+: define-constructor ( name class effect body -- )
+    [ [ in>> ] dip constructor-quot ] [ drop ] 2bi
+    define-declared ;
+
+: CONSTRUCTOR:
+    scan-word [ name>> "<" ">" surround create-in ] keep
+    "(" expect ")" parse-effect
+    parse-definition
+    define-constructor ; parsing
\ No newline at end of file