/extra/constructors/constructors.factor

http://github.com/abeaumont/factor · Factor · 71 lines · 52 code · 17 blank · 2 comment · 3 complexity · 54fade285425a1127f5bec6e4b6338ef MD5 · raw file

  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. : all-slots-assoc ( class -- slots )
  9. superclasses [
  10. [ "slots" word-prop ] keep '[ _ ] { } map>assoc
  11. ] map concat ;
  12. MACRO:: slots>boa ( slots class -- quot )
  13. class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
  14. class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
  15. slots length
  16. default-params length
  17. '[
  18. _ narray slot-assoc swap zip
  19. default-params swap assoc-union values _ firstn class boa
  20. ] ;
  21. ERROR: repeated-constructor-parameters class effect ;
  22. ERROR: unknown-constructor-parameters class effect unknown ;
  23. : ensure-constructor-parameters ( class effect -- class effect )
  24. dup in>> all-unique? [ repeated-constructor-parameters ] unless
  25. 2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
  26. [ unknown-constructor-parameters ] unless-empty ;
  27. : constructor-boa-quot ( constructor-word class effect -- word quot )
  28. in>> swap '[ _ _ slots>boa ] ; inline
  29. : define-constructor ( constructor-word class effect -- )
  30. ensure-constructor-parameters
  31. [ constructor-boa-quot ] keep define-declared ;
  32. : create-reset ( string -- word )
  33. create-in dup reset-generic ;
  34. : scan-constructor ( -- word class )
  35. scan-word [ name>> "<" ">" surround create-function ] keep ;
  36. : parse-constructor ( -- word class effect def )
  37. scan-constructor scan-effect ensure-constructor-parameters
  38. parse-definition ;
  39. SYNTAX: CONSTRUCTOR:
  40. parse-constructor
  41. [ [ constructor-boa-quot ] dip compose ]
  42. [ drop ] 2bi define-declared ;
  43. : scan-rest-input-effect ( -- effect )
  44. ")" parse-effect-tokens nip
  45. { "obj" } <effect> ;
  46. : scan-full-input-effect ( -- effect )
  47. "(" expect scan-rest-input-effect ;
  48. SYNTAX: NAMED-CONSTRUCTOR:
  49. scan-new-word scan-word scan-effect define-constructor ;
  50. SYNTAX: DEFAULT-CONSTRUCTOR:
  51. scan-constructor scan-effect define-constructor ;
  52. SYNTAX: CONSTRUCTOR-SYNTAX:
  53. scan-word [ name>> "(" append create-reset ] keep
  54. '[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ;