basis/constructors/constructors.factor

   1 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs classes classes.tuple effects
   4 effects.parser fry kernel lexer locals macros parser
   5 sequences sequences.generalizations sets vocabs vocabs.parser
   6 words alien.parser ;
   7 IN: constructors
   8
   9 : all-slots-assoc ( class -- slots )
  10     superclasses-of [
  11         [ "slots" word-prop ] keep '[ _ ] { } map>assoc
  12     ] map concat ;
  13
  14 MACRO:: slots>boa ( slots class -- quot )
  15     class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
  16     class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
  17     slots length
  18     default-params length
  19     '[
  20         _ narray slot-assoc swap zip
  21         default-params swap assoc-union values _ firstn class boa
  22     ] ;
  23
  24 ERROR: repeated-constructor-parameters class effect ;
  25
  26 ERROR: unknown-constructor-parameters class effect unknown ;
  27
  28 : ensure-constructor-parameters ( class effect -- class effect )
  29     dup in>> all-unique? [ repeated-constructor-parameters ] unless
  30     2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
  31     [ unknown-constructor-parameters ] unless-empty ;
  32
  33 : constructor-boa-quot ( constructor-word class effect -- word quot )
  34     in>> swap '[ _ _ slots>boa ] ; inline
  35
  36 : define-constructor ( constructor-word class effect -- )
  37     ensure-constructor-parameters
  38     [ constructor-boa-quot ] keep define-declared ;
  39
  40 : create-reset ( string -- word )
  41     create-word-in dup reset-generic ;
  42
  43 : scan-constructor ( -- word class )
  44     scan-new-word scan-class ;
  45
  46 : parse-constructor ( -- word class effect def )
  47     scan-constructor scan-effect ensure-constructor-parameters
  48     parse-definition ;
  49
  50 SYNTAX: CONSTRUCTOR:
  51     parse-constructor
  52     [ [ constructor-boa-quot ] dip compose ]
  53     [ drop ] 2bi define-declared ;
  54
  55 : scan-rest-input-effect ( -- effect )
  56     ")" parse-effect-tokens nip
  57     { "obj" } <effect> ;
  58
  59 : scan-full-input-effect ( -- effect )
  60     "(" expect scan-rest-input-effect ;
  61
  62 SYNTAX: SLOT-CONSTRUCTOR:
  63     scan-new-word [ name>> "(" append create-reset ] keep
  64     '[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ;