core/inference/transforms/transforms.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel words sequences generic math namespaces
   4 quotations assocs combinators math.bitfields inference.backend
   5 inference.dataflow inference.state classes.tuple.private effects
   6 inspector hashtables classes generic sets definitions ;
   7 IN: inference.transforms
   8
   9 : pop-literals ( n -- rstate seq )
  10     dup zero? [
  11         drop recursive-state get { }
  12     ] [
  13         dup ensure-values
  14         f swap [ 2drop pop-literal ] map reverse
  15     ] if ;
  16
  17 : transform-quot ( quot n -- newquot )
  18     [ pop-literals [ ] each ] curry
  19     swap
  20     [ swap infer-quot ] 3compose ;
  21
  22 : define-transform ( word quot n -- )
  23     transform-quot "infer" set-word-prop ;
  24
  25 ! Combinators
  26 \ cond [
  27     cond>quot
  28 ] 1 define-transform
  29
  30 \ case [
  31     dup empty? [
  32         drop [ no-case ]
  33     ] [
  34         dup peek quotation? [
  35             dup peek swap but-last
  36         ] [
  37             [ no-case ] swap
  38         ] if case>quot
  39     ] if
  40 ] 1 define-transform
  41
  42 \ cleave [ cleave>quot ] 1 define-transform
  43
  44 \ 2cleave [ 2cleave>quot ] 1 define-transform
  45
  46 \ 3cleave [ 3cleave>quot ] 1 define-transform
  47
  48 \ spread [ spread>quot ] 1 define-transform
  49
  50 ! Bitfields
  51 GENERIC: (bitfield-quot) ( spec -- quot )
  52
  53 M: integer (bitfield-quot) ( spec -- quot )
  54     [ swapd shift bitor ] curry ;
  55
  56 M: pair (bitfield-quot) ( spec -- quot )
  57     first2 over word? [ >r swapd execute r> ] [ ] ?
  58     [ shift bitor ] append 2curry ;
  59
  60 : bitfield-quot ( spec -- quot )
  61     [ (bitfield-quot) ] map [ 0 ] prefix concat ;
  62
  63 \ bitfield [ bitfield-quot ] 1 define-transform
  64
  65 \ flags [
  66     [ 0 , [ , \ bitor , ] each ] [ ] make
  67 ] 1 define-transform
  68
  69 ! Tuple operations
  70 : [get-slots] ( slots -- quot )
  71     [ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;
  72
  73 \ get-slots [ [get-slots] ] 1 define-transform
  74
  75 ERROR: duplicated-slots-error names ;
  76
  77 M: duplicated-slots-error summary
  78     drop "Calling set-slots with duplicate slot setters" ;
  79
  80 \ set-slots [
  81     dup all-unique?
  82     [ <reversed> [get-slots] ] [ duplicated-slots-error ] if
  83 ] 1 define-transform
  84
  85 \ boa [
  86     dup +inlined+ depends-on
  87     tuple-layout [ <tuple-boa> ] curry
  88 ] 1 define-transform
  89
  90 \ new [
  91     1 ensure-values
  92     peek-d value? [
  93         pop-literal
  94         dup +inlined+ depends-on
  95         tuple-layout [ <tuple> ] curry
  96         swap infer-quot
  97     ] [
  98         \ new 1 1 <effect> make-call-node
  99     ] if
 100 ] "infer" set-word-prop
 101
 102 \ instance? [
 103     [ +inlined+ depends-on ] [ "predicate" word-prop ] bi
 104 ] 1 define-transform
 105
 106 \ (call-next-method) [
 107     [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
 108 ] 2 define-transform