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     dup [ 2nip ] [ drop 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-word localize dupd read-local-quot [ call ] append ;
  25
  26 M: local-reader localize dupd read-local-quot [ local-value ] append ;
  27
  28 M: local-writer localize
  29     dupd "local-reader" word-prop
  30     read-local-quot [ set-local-value ] append ;
  31
  32 M: def localize
  33     local>>
  34     [ prefix ]
  35     [ local-reader? [ 1array load-local ] [ load-local ] ? ]
  36     bi ;
  37
  38 M: object localize 1quotation ;
  39
  40 ! We special-case all the :> at the start of a quotation
  41 : load-locals-quot ( args -- quot )
  42     [ [ ] ] [
  43         dup [ local-reader? ] any? [
  44             dup [ local-reader? [ 1array ] [ ] ? ] map
  45             spread>quot
  46         ] [ [ ] ] if swap length [ load-locals ] curry append
  47     ] if-empty ;
  48
  49 : load-locals-index ( quot -- n )
  50     [ [ dup def? [ local>> local-reader? ] [ drop t ] if ] find drop ]
  51     [ length ] bi or ;
  52
  53 : point-free-start ( quot -- args rest )
  54     dup load-locals-index
  55     cut [ [ local>> ] map dup <reversed> load-locals-quot % ] dip ;
  56
  57 : point-free-body ( args quot -- args )
  58     [ localize % ] each ;
  59
  60 : drop-locals-quot ( args -- )
  61     [ length , [ drop-locals ] % ] unless-empty ;
  62
  63 : point-free-end ( args obj -- )
  64     dup special?
  65     [ localize % drop-locals-quot ]
  66     [ [ drop-locals-quot ] [ , ] bi* ]
  67     if ;
  68
  69 : point-free ( quot -- newquot )
  70     [
  71         point-free-start
  72         [ drop-locals-quot ] [
  73             unclip-last
  74             [ point-free-body ]
  75             [ point-free-end ]
  76             bi*
  77         ] if-empty
  78     ] [ ] make ;