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 fry.private kernel
   4 locals.backend locals.errors locals.types make math quotations
   5 sequences words ;
   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 ] [ 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: multi-def localize
  31     locals>> <reversed>
  32     [ prepend ]
  33     [ [ [ local-reader? ] dip '[ [ 1array ] _ [ndip] ] [ [ ] ] if ] map-index concat ]
  34     [
  35         length {
  36             { [ dup 1 > ] [ [ load-locals ] curry ] }
  37             { [ dup 1 = ] [ drop [ load-local ] ] }
  38             [ drop [ ] ]
  39         } cond
  40     ] tri append ;
  41
  42 M: object localize 1quotation ;
  43
  44 : drop-locals-quot ( args -- )
  45     [ length , [ drop-locals ] % ] unless-empty ;
  46
  47 : point-free ( quot -- newquot )
  48     [ { } swap [ localize % ] each drop-locals-quot ] [ ] make ;