basis/constructors/constructors.factor

   1 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: slots kernel sequences fry accessors parser lexer words
   4 effects.parser macros generalizations locals classes.tuple
   5 vocabs generic.standard ;
   6 IN: constructors
   7
   8 ! An experiment
   9
  10 : initializer-name ( class -- word )
  11     name>> "initialize-" prepend ;
  12
  13 : lookup-initializer ( class -- word/f )
  14     initializer-name "initializers" lookup ;
  15
  16 : initializer-word ( class -- word )
  17     initializer-name
  18     "initializers" create-vocab create
  19     [ t "initializer" set-word-prop ] [ ] bi ;
  20
  21 : define-initializer-generic ( name -- )
  22     initializer-word (( object -- object )) define-simple-generic ;
  23
  24 : define-initializer ( class def -- )
  25     [ drop define-initializer-generic ]
  26     [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
  27
  28 MACRO:: slots>constructor ( class slots -- quot )
  29     slots class
  30     all-slots [ name>> ] map
  31     [ '[ _ = ] find drop ] with map
  32     [ [ ] count ] [ ] [ length ] tri
  33     '[
  34         _ narray _
  35         [ swap over [ nth ] [ drop ] if ] with map
  36         _ firstn class boa
  37     ] ;
  38
  39 :: define-constructor ( constructor-word class effect def -- )
  40     constructor-word
  41     class def define-initializer
  42     class effect in>> '[ _ _ slots>constructor ]
  43     class lookup-initializer
  44     '[ @ _ execute( obj -- obj ) ] effect define-declared ;
  45
  46 : scan-constructor ( -- class word )
  47     scan-word [ name>> "<" ">" surround create-in ] keep ;
  48
  49 SYNTAX: CONSTRUCTOR:
  50     scan-constructor
  51     complete-effect
  52     parse-definition
  53     define-constructor ;