basis/locals/rewrite/sugar/sugar.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.tuple fry
   4 generalizations hashtables kernel locals locals.backend
   5 locals.errors locals.types make quotations sequences vectors
   6 words ;
   7 IN: locals.rewrite.sugar
   8
   9 ! Step 1: rewrite [| [let [let* [wlet into :> forms, turn
  10 ! literals with locals in them into code which constructs
  11 ! the literal after pushing locals on the stack
  12
  13 GENERIC: rewrite-sugar* ( obj -- )
  14
  15 : (rewrite-sugar) ( form -- form' )
  16     [ rewrite-sugar* ] [ ] make ;
  17
  18 GENERIC: quotation-rewrite ( form -- form' )
  19
  20 M: callable quotation-rewrite [ [ rewrite-sugar* ] each ] [ ] make ;
  21
  22 : var-defs ( vars -- defs ) <reversed> [ <def> ] [ ] map-as ;
  23
  24 M: lambda quotation-rewrite
  25     [ body>> ] [ vars>> var-defs ] bi
  26     prepend quotation-rewrite ;
  27
  28 M: callable rewrite-sugar* quotation-rewrite , ;
  29
  30 M: lambda rewrite-sugar* quotation-rewrite , ;
  31
  32 GENERIC: rewrite-literal? ( obj -- ? )
  33
  34 M: special rewrite-literal? drop t ;
  35
  36 M: array rewrite-literal? [ rewrite-literal? ] contains? ;
  37
  38 M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
  39
  40 M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
  41
  42 M: hashtable rewrite-literal? drop t ;
  43
  44 M: vector rewrite-literal? drop t ;
  45
  46 M: tuple rewrite-literal? drop t ;
  47
  48 M: object rewrite-literal? drop f ;
  49
  50 GENERIC: rewrite-element ( obj -- )
  51
  52 : rewrite-elements ( seq -- )
  53     [ rewrite-element ] each ;
  54
  55 : rewrite-sequence ( seq -- )
  56     [ rewrite-elements ] [ length ] [ 0 head ] tri '[ _ _ nsequence ] % ;
  57
  58 M: array rewrite-element
  59     dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
  60
  61 M: vector rewrite-element rewrite-sequence ;
  62
  63 M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
  64
  65 M: tuple rewrite-element
  66     [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ;
  67
  68 M: quotation rewrite-element rewrite-sugar* ;
  69
  70 M: lambda rewrite-element rewrite-sugar* ;
  71
  72 M: binding-form rewrite-element binding-form-in-literal-error ;
  73
  74 M: local rewrite-element , ;
  75
  76 M: local-reader rewrite-element , ;
  77
  78 M: local-writer rewrite-element
  79     local-writer-in-literal-error ;
  80
  81 M: local-word rewrite-element
  82     local-word-in-literal-error ;
  83
  84 M: word rewrite-element literalize , ;
  85
  86 M: wrapper rewrite-element
  87     dup rewrite-literal? [ wrapped>> rewrite-element \ literalize , ] [ , ] if ;
  88
  89 M: object rewrite-element , ;
  90
  91 M: array rewrite-sugar* rewrite-element ;
  92
  93 M: vector rewrite-sugar* rewrite-element ;
  94
  95 M: tuple rewrite-sugar* rewrite-element ;
  96
  97 M: def rewrite-sugar* , ;
  98
  99 M: hashtable rewrite-sugar* rewrite-element ;
 100
 101 M: wrapper rewrite-sugar*
 102     dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
 103
 104 M: word rewrite-sugar*
 105     dup { load-locals get-local drop-locals } memq?
 106     [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
 107
 108 M: object rewrite-sugar* , ;
 109
 110 : let-rewrite ( body bindings -- )
 111     [ quotation-rewrite % <def> , ] assoc-each
 112     quotation-rewrite % ;
 113
 114 M: let rewrite-sugar*
 115     [ body>> ] [ bindings>> ] bi let-rewrite ;
 116
 117 M: let* rewrite-sugar*
 118     [ body>> ] [ bindings>> ] bi let-rewrite ;
 119
 120 M: wlet rewrite-sugar*
 121     [ body>> ] [ bindings>> ] bi
 122     [ '[ _ ] ] assoc-map
 123     let-rewrite ;