extra/constructors/constructors.factor

   1 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.tuple
   4 effects.parser fry generalizations generic.standard kernel
   5 lexer locals macros parser sequences sets slots vocabs words ;
   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 : all-slots-assoc ( class -- slots )
  29     superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ;
  30
  31 MACRO:: slots>constructor ( class slots -- quot )
  32     class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
  33     class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
  34     slots length
  35     default-params length
  36     '[
  37         _ narray slot-assoc swap zip
  38         default-params swap assoc-union values _ firstn class boa
  39     ] ;
  40
  41 ERROR: repeated-constructor-parameters class effect ;
  42
  43 ERROR: unknown-constructor-parameters class effect unknown ;
  44
  45 : ensure-constructor-parameters ( class effect -- class effect )
  46     dup in>> all-unique? [ repeated-constructor-parameters ] unless
  47     2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
  48     [ unknown-constructor-parameters ] unless-empty ;
  49
  50 :: (define-constructor) ( constructor-word class effect def -- word quot )
  51     constructor-word
  52     class def define-initializer
  53     class effect in>> '[ _ _ slots>constructor ] ;
  54
  55 :: define-constructor ( constructor-word class effect def reverse? -- )
  56     constructor-word class effect def (define-constructor)
  57     class superclasses [ lookup-initializer ] map sift
  58     reverse? [ reverse ] when
  59     '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
  60
  61 : scan-constructor ( -- word class )
  62     scan-word [ name>> "<" ">" surround create-in dup reset-generic ] keep ;
  63
  64 : parse-constructor ( -- class word effect def )
  65     scan-constructor complete-effect ensure-constructor-parameters
  66     parse-definition ;
  67
  68 SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
  69
  70 "initializers" create-vocab drop