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 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 ) <reversed> [ <def> ] [ ] map-as ;
24 M: lambda quotation-rewrite
25 [ body>> ] [ vars>> var-defs ] bi
26 prepend quotation-rewrite ;
28 M: callable rewrite-sugar* quotation-rewrite , ;
30 M: lambda rewrite-sugar* quotation-rewrite , ;
32 GENERIC: rewrite-literal? ( obj -- ? )
34 M: special rewrite-literal? drop t ;
36 M: array rewrite-literal? [ rewrite-literal? ] any? ;
38 M: quotation rewrite-literal? [ rewrite-literal? ] any? ;
40 M: vector rewrite-literal? [ rewrite-literal? ] any? ;
42 M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
44 M: hashtable rewrite-literal? >alist rewrite-literal? ;
46 M: tuple rewrite-literal? tuple>array rewrite-literal? ;
48 M: object rewrite-literal? drop f ;
50 GENERIC: rewrite-element ( obj -- )
52 : rewrite-elements ( seq -- )
53 [ rewrite-element ] each ;
55 : rewrite-sequence ( seq -- )
56 [ rewrite-elements ] [ length ] [ 0 head ] tri '[ _ _ nsequence ] % ;
58 M: array rewrite-element
59 dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
61 M: vector rewrite-element
62 dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
64 M: hashtable rewrite-element
65 dup rewrite-literal? [ >alist rewrite-sequence \ >hashtable , ] [ , ] if ;
67 M: tuple rewrite-element
68 dup rewrite-literal? [
69 [ tuple-slots rewrite-elements ] [ class-of ] bi '[ _ boa ] %
72 M: quotation rewrite-element rewrite-sugar* ;
74 M: lambda rewrite-element rewrite-sugar* ;
76 M: let rewrite-element throw-let-form-in-literal-error ;
78 M: local rewrite-element , ;
80 M: local-reader rewrite-element , ;
82 M: local-writer rewrite-element
83 throw-local-writer-in-literal-error ;
85 M: word rewrite-element <wrapper> , ;
87 : rewrite-wrapper ( wrapper -- )
89 [ wrapped>> rewrite-element ] [ , ] if ;
91 M: wrapper rewrite-element
92 rewrite-wrapper \ <wrapper> , ;
94 M: object rewrite-element , ;
96 M: array rewrite-sugar* rewrite-element ;
98 M: vector rewrite-sugar* rewrite-element ;
100 M: tuple rewrite-sugar* rewrite-element ;
102 M: def rewrite-sugar* , ;
104 M: multi-def rewrite-sugar* locals>> <reversed> [ <def> , ] each ;
106 M: hashtable rewrite-sugar* rewrite-element ;
108 M: wrapper rewrite-sugar*
111 M: word rewrite-sugar*
112 dup { load-locals get-local drop-locals } member-eq?
113 [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
115 M: object rewrite-sugar* , ;
117 M: let rewrite-sugar*
118 body>> quotation-rewrite % ;