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