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 sequences.generalizations hashtables kernel locals locals.backend
5 locals.errors locals.types make math quotations sequences vectors
7 IN: locals.rewrite.sugar
9 ! Step 1: rewrite [| into :> forms, turn
10 ! literals with locals in them into code which constructs
11 ! the literal after pushing locals on the stack
13 GENERIC: rewrite-sugar* ( obj -- )
15 : (rewrite-sugar) ( form -- form' )
16 [ rewrite-sugar* ] [ ] make ;
18 GENERIC: quotation-rewrite ( form -- form' )
20 M: callable quotation-rewrite [ [ rewrite-sugar* ] each ] [ ] make ;
22 : var-defs ( vars -- defs )
24 <multi-def> 1quotation
26 <reversed> [ <def> ] [ ] map-as
29 M: lambda quotation-rewrite
30 [ body>> ] [ vars>> var-defs ] bi prepend quotation-rewrite ;
32 M: callable rewrite-sugar* quotation-rewrite , ;
34 M: lambda rewrite-sugar* quotation-rewrite , ;
36 GENERIC: rewrite-literal? ( obj -- ? )
38 M: special rewrite-literal? drop t ;
40 M: array rewrite-literal? [ rewrite-literal? ] any? ;
42 M: quotation rewrite-literal? [ rewrite-literal? ] any? ;
44 M: vector rewrite-literal? [ rewrite-literal? ] any? ;
46 M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
48 M: hashtable rewrite-literal? >alist rewrite-literal? ;
50 M: tuple rewrite-literal? tuple>array rewrite-literal? ;
52 M: object rewrite-literal? drop f ;
54 GENERIC: rewrite-element ( obj -- )
56 : rewrite-elements ( seq -- )
57 [ rewrite-element ] each ;
59 : rewrite-sequence ( seq -- )
60 [ rewrite-elements ] [ length ] [ 0 head ] tri '[ _ _ nsequence ] % ;
62 M: array rewrite-element
63 dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
65 M: vector rewrite-element
66 dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
68 M: hashtable rewrite-element
69 dup rewrite-literal? [ >alist rewrite-sequence \ >hashtable , ] [ , ] if ;
71 M: tuple rewrite-element
72 dup rewrite-literal? [
73 [ tuple-slots rewrite-elements ] [ class-of ] bi '[ _ boa ] %
76 M: quotation rewrite-element rewrite-sugar* ;
78 M: lambda rewrite-element rewrite-sugar* ;
80 M: let rewrite-element let-form-in-literal-error ;
82 M: local rewrite-element , ;
84 M: local-reader rewrite-element , ;
86 M: local-writer rewrite-element
87 local-writer-in-literal-error ;
89 M: word rewrite-element <wrapper> , ;
91 : rewrite-wrapper ( wrapper -- )
92 dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
94 M: wrapper rewrite-element
95 rewrite-wrapper \ <wrapper> , ;
97 M: object rewrite-element , ;
99 M: array rewrite-sugar* rewrite-element ;
101 M: vector rewrite-sugar* rewrite-element ;
103 M: tuple rewrite-sugar* rewrite-element ;
105 M: def rewrite-sugar* , ;
107 M: multi-def rewrite-sugar* , ;
109 M: hashtable rewrite-sugar* rewrite-element ;
111 M: wrapper rewrite-sugar*
114 M: word rewrite-sugar*
115 dup { load-locals get-local drop-locals } member-eq?
116 [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
118 M: object rewrite-sugar* , ;
120 M: let rewrite-sugar*
121 body>> quotation-rewrite % ;