core/inference/transforms/transforms.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays kernel words sequences generic math
   4 namespaces quotations assocs combinators
   5 inference.backend inference.dataflow inference.state
   6 classes.tuple classes.tuple.private effects summary hashtables
   7 classes generic sets definitions generic.standard slots.private ;
   8 IN: inference.transforms
   9
  10 : pop-literals ( n -- rstate seq )
  11     dup zero? [
  12         drop recursive-state get { }
  13     ] [
  14         dup ensure-values
  15         f swap [ 2drop pop-literal ] map reverse
  16     ] if ;
  17
  18 : transform-quot ( quot n -- newquot )
  19     [ pop-literals [ ] each ] curry
  20     swap
  21     [ swap infer-quot ] 3compose ;
  22
  23 : define-transform ( word quot n -- )
  24     transform-quot "infer" set-word-prop ;
  25
  26 ! Combinators
  27 \ cond [
  28     cond>quot
  29 ] 1 define-transform
  30
  31 \ case [
  32     dup empty? [
  33         drop [ no-case ]
  34     ] [
  35         dup peek quotation? [
  36             dup peek swap but-last
  37         ] [
  38             [ no-case ] swap
  39         ] if case>quot
  40     ] if
  41 ] 1 define-transform
  42
  43 \ cleave [ cleave>quot ] 1 define-transform
  44
  45 \ 2cleave [ 2cleave>quot ] 1 define-transform
  46
  47 \ 3cleave [ 3cleave>quot ] 1 define-transform
  48
  49 \ spread [ spread>quot ] 1 define-transform
  50
  51 ! Tuple operations
  52 : [get-slots] ( slots -- quot )
  53     [ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;
  54
  55 \ get-slots [ [get-slots] ] 1 define-transform
  56
  57 ERROR: duplicated-slots-error names ;
  58
  59 M: duplicated-slots-error summary
  60     drop "Calling set-slots with duplicate slot setters" ;
  61
  62 \ set-slots [
  63     dup all-unique?
  64     [ <reversed> [get-slots] ] [ duplicated-slots-error ] if
  65 ] 1 define-transform
  66
  67 \ boa [
  68     dup tuple-class? [
  69         dup +inlined+ depends-on
  70         [ "boa-check" word-prop ]
  71         [ tuple-layout [ <tuple-boa> ] curry ]
  72         bi append
  73     ] [
  74         \ boa \ no-method boa time-bomb
  75     ] if
  76 ] 1 define-transform
  77
  78 \ (call-next-method) [
  79     [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
  80 ] 2 define-transform