basis/locals/rewrite/point-free/point-free.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays fry kernel math quotations sequences
   4 words combinators make locals.backend locals.types
   5 locals.errors ;
   6 IN: locals.rewrite.point-free
   7
   8 ! Step 3: rewrite locals usage within a single quotation into
   9 ! retain stack manipulation
  10
  11 : local-index ( args obj -- n )
  12     2dup '[ unquote _ eq? ] find drop
  13     [ 2nip ] [ throw-bad-local ] if* ;
  14
  15 : read-local-quot ( args obj -- quot )
  16     local-index neg [ get-local ] curry ;
  17
  18 GENERIC: localize ( args obj -- args quot )
  19
  20 M: local localize dupd read-local-quot ;
  21
  22 M: quote localize dupd local>> read-local-quot ;
  23
  24 M: local-reader localize dupd read-local-quot [ local-value ] append ;
  25
  26 M: local-writer localize
  27     dupd "local-reader" word-prop
  28     read-local-quot [ set-local-value ] append ;
  29
  30 M: def localize
  31     local>>
  32     [ prefix ]
  33     [ local-reader? [ 1array load-local ] [ load-local ] ? ]
  34     bi ;
  35
  36 M: object localize 1quotation ;
  37
  38 ! We special-case all the :> at the start of a quotation
  39 : load-locals-quot ( args -- quot )
  40     [ [ ] ] [
  41         dup [ local-reader? ] any? [
  42             dup [ local-reader? [ 1array ] [ ] ? ] map
  43             deep-spread>quot
  44         ] [ [ ] ] if swap length [ load-locals ] curry append
  45     ] if-empty ;
  46
  47 : load-locals-index ( quot -- n )
  48     [ [ dup def? [ local>> local-reader? ] [ drop t ] if ] find drop ]
  49     [ length ] bi or ;
  50
  51 : point-free-start ( quot -- args rest )
  52     dup load-locals-index
  53     cut [ [ local>> ] map dup <reversed> load-locals-quot % ] dip ;
  54
  55 : point-free-body ( args quot -- args )
  56     [ localize % ] each ;
  57
  58 : drop-locals-quot ( args -- )
  59     [ length , [ drop-locals ] % ] unless-empty ;
  60
  61 : point-free-end ( args obj -- )
  62     dup special?
  63     [ localize % drop-locals-quot ]
  64     [ [ drop-locals-quot ] [ , ] bi* ]
  65     if ;
  66
  67 : point-free ( quot -- newquot )
  68     [
  69         point-free-start
  70         [ drop-locals-quot ] [
  71             unclip-last
  72             [ point-free-body ]
  73             [ point-free-end ]
  74             bi*
  75         ] if-empty
  76     ] [ ] make ;