basis/compiler/tree/normalization/renaming/renaming.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs compiler.tree compiler.tree.combinators
   4 fry kernel namespaces sequences ;
   5 IN: compiler.tree.normalization.renaming
   6
   7 SYMBOL: rename-map
   8
   9 : rename-value ( value -- value' )
  10     [ rename-map get at ] keep or ;
  11
  12 : rename-values ( values -- values' )
  13     dup empty? [ rename-map get '[ [ _ at ] keep or ] map ] unless ;
  14
  15 : add-renamings ( old new -- )
  16     [ rename-values ] dip
  17     rename-map get '[ _ set-at ] 2each ;
  18
  19 GENERIC: rename-node-values* ( node -- node )
  20
  21 M: #introduce rename-node-values* ;
  22
  23 M: #shuffle rename-node-values*
  24     [ rename-values ] change-in-d
  25     [ rename-values ] change-in-r
  26     [ [ rename-value ] assoc-map ] change-mapping ;
  27
  28 M: #push rename-node-values* ;
  29
  30 M: #terminate rename-node-values*
  31     [ rename-values ] change-in-d
  32     [ rename-values ] change-in-r ;
  33
  34 M: #phi rename-node-values*
  35     [ [ rename-values ] map ] change-phi-in-d ;
  36
  37 M: #declare rename-node-values*
  38     [ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
  39
  40 M: #alien-callback rename-node-values* ;
  41
  42 M: node rename-node-values*
  43     [ rename-values ] change-in-d ;
  44
  45 : rename-node-values ( nodes -- nodes' )
  46     dup [ rename-node-values* drop ] each-node ;