From a46d7b34f2bdb33e9767e287c13e8cd3eefd5898 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Jan 2009 14:40:08 -0600
Subject: [PATCH] Constructors experiment

---
 extra/constructors/authors.txt               |  1 +
 extra/constructors/constructors-tests.factor | 21 ++++++++++++++++++++
 extra/constructors/constructors.factor       | 21 ++++++++++++++++++++
 3 files changed, 43 insertions(+)
 create mode 100644 extra/constructors/authors.txt
 create mode 100644 extra/constructors/constructors-tests.factor
 create mode 100644 extra/constructors/constructors.factor

diff --git a/extra/constructors/authors.txt b/extra/constructors/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /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
index 0000000000..367f0ad143
--- /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
index 0000000000..6968fd7eda
--- /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