core/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 combinators kernel locals.backend
   4 locals.errors locals.types make math quotations sequences words ;
   5 IN: locals.rewrite.point-free
   6
   7 ! Step 3: rewrite locals usage within a single quotation into
   8 ! retain stack manipulation
   9
  10 : local-index ( args obj -- n )
  11     2dup '[ unquote _ eq? ] find drop
  12     [ 2nip ] [ bad-local ] if* ;
  13
  14 : read-local-quot ( args obj -- quot )
  15     local-index neg [ get-local ] curry ;
  16
  17 GENERIC: localize ( args obj -- args quot )
  18
  19 M: local localize dupd read-local-quot ;
  20
  21 M: quote localize dupd local>> read-local-quot ;
  22
  23 M: local-reader localize dupd read-local-quot [ local-value ] append ;
  24
  25 M: local-writer localize
  26     dupd "local-reader" word-prop
  27     read-local-quot [ set-local-value ] append ;
  28
  29 M: def localize
  30     local>>
  31     [ prefix ]
  32     [ local-reader? [ 1array load-local ] [ load-local ] ? ]
  33     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? ] any? [
  41             dup [ local-reader? [ 1array ] [ ] ? ] map
  42             deep-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 ;