factor: trim using lists

[factor.git] / basis / constructors / constructors.factor

diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor
index e6982e3d98aaaf7961f2ff54b1c59dcc319451ea..974635fdbee29baebbcb20a5baf7f3659ca4f800 100644 (file)
--- a/basis/constructors/constructors.factor
+++ b/basis/constructors/constructors.factor
@@ -1,54 +1,63 @@
 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs classes.tuple effects.parser fry
-generalizations generic.standard kernel lexer locals macros
-parser sequences slots vocabs words ;
+USING: accessors assocs classes classes.tuple effects
+effects.parser kernel lexer parser sequences
+sequences.generalizations sets words ;
 IN: constructors
 
-! An experiment
+: all-slots-assoc ( class -- slots )
+    superclasses-of [
+        [ "slots" word-prop ] keep '[ _ ] { } map>assoc
+    ] map concat ;
 
-: initializer-name ( class -- word )
-    name>> "initialize-" prepend ;
+MACRO:: slots>boa ( slots class -- quot )
+    class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
+    class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
+    slots length
+    default-params length
+    '[
+        _ narray slot-assoc swap zip
+        default-params swap assoc-union values _ firstn class boa
+    ] ;
 
-: lookup-initializer ( class -- word/f )
-    initializer-name "initializers" lookup ;
+ERROR: repeated-constructor-parameters class effect ;
 
-: initializer-word ( class -- word )
-    initializer-name
-    "initializers" create-vocab create
-    [ t "initializer" set-word-prop ] [ ] bi ;
+ERROR: unknown-constructor-parameters class effect unknown ;
 
-: define-initializer-generic ( name -- )
-    initializer-word (( object -- object )) define-simple-generic ;
+: ensure-constructor-parameters ( class effect -- class effect )
+    dup in>> all-unique? [ repeated-constructor-parameters ] unless
+    2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
+    [ unknown-constructor-parameters ] unless-empty ;
 
-: define-initializer ( class def -- )
-    [ drop define-initializer-generic ]
-    [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
+: constructor-boa-quot ( constructor-word class effect -- word quot )
+    in>> swap '[ _ _ slots>boa ] ; inline
 
-MACRO:: slots>constructor ( class slots -- quot )
-    class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
-    slots length
-    params length
-    '[
-        _ narray slots swap zip 
-        params swap assoc-union
-        values _ firstn class boa
-    ] ;
+: define-constructor ( constructor-word class effect -- )
+    ensure-constructor-parameters
+    [ constructor-boa-quot ] keep define-declared ;
+
+: create-reset ( string -- word )
+    create-word-in dup reset-generic ;
 
-:: define-constructor ( constructor-word class effect def -- )
-    constructor-word
-    class def define-initializer
-    class effect in>> '[ _ _ slots>constructor ]
-    class lookup-initializer
-    '[ @ _ execute( obj -- obj ) ] effect define-declared ;
+: scan-constructor ( -- word class )
+    scan-new-word scan-class ;
 
-: scan-constructor ( -- class word )
-    scan-word [ name>> "<" ">" surround create-in ] keep ;
+: parse-constructor ( -- word class effect def )
+    scan-constructor scan-effect ensure-constructor-parameters
+    parse-definition ;
 
 SYNTAX: CONSTRUCTOR:
-    scan-constructor
-    complete-effect
-    parse-definition
-    define-constructor ;
+    parse-constructor
+    [ [ constructor-boa-quot ] dip compose ]
+    [ drop ] 2bi define-declared ;
+
+: scan-rest-input-effect ( -- effect )
+    ")" parse-effect-tokens nip
+    { "obj" } <effect> ;
+
+: scan-full-input-effect ( -- effect )
+    "(" expect scan-rest-input-effect ;
 
-"initializers" create-vocab drop
+SYNTAX: SLOT-CONSTRUCTOR:
+    scan-new-word [ name>> "(" append create-reset ] keep
+    '[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ;