1 ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel namespaces sequences sequences.private assocs math
4 inference.transforms parser words quotations debugger macros
5 arrays macros splitting combinators prettyprint.backend
6 definitions prettyprint hashtables prettyprint.sections sets
7 sequences.private effects effects.parser generic generic.parser
8 compiler.units accessors locals.backend memoize lexer ;
12 ! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
16 TUPLE: lambda vars body ;
20 TUPLE: let bindings body ;
24 TUPLE: let* bindings body ;
28 TUPLE: wlet bindings body ;
32 PREDICATE: local < word "local?" word-prop ;
34 : <local> ( name -- word )
35 #! Create a local variable identifier
36 f <word> dup t "local?" set-word-prop ;
38 PREDICATE: local-word < word "local-word?" word-prop ;
40 : <local-word> ( name -- word )
41 f <word> dup t "local-word?" set-word-prop ;
43 PREDICATE: local-reader < word "local-reader?" word-prop ;
45 : <local-reader> ( name -- word )
46 f <word> dup t "local-reader?" set-word-prop ;
48 PREDICATE: local-writer < word "local-writer?" word-prop ;
50 : <local-writer> ( reader -- word )
51 dup name>> "!" append f <word>
52 [ t "local-writer?" set-word-prop ] keep
53 [ "local-writer" set-word-prop ] 2keep
54 [ swap "local-reader" set-word-prop ] keep ;
60 : local-index ( obj args -- n )
61 [ dup quote? [ quote-local ] when eq? ] with find drop ;
63 : read-local-quot ( obj args -- quot )
64 local-index 1+ [ get-local ] curry ;
66 : localize-writer ( obj args -- quot )
67 >r "local-reader" word-prop r>
68 read-local-quot [ set-local-value ] append ;
70 : localize ( obj args -- quot )
72 { [ over local? ] [ read-local-quot ] }
73 { [ over quote? ] [ >r quote-local r> read-local-quot ] }
74 { [ over local-word? ] [ read-local-quot [ call ] append ] }
75 { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
76 { [ over local-writer? ] [ localize-writer ] }
77 { [ over \ lambda eq? ] [ 2drop [ ] ] }
78 { [ t ] [ drop 1quotation ] }
81 UNION: special local quote local-word local-reader local-writer ;
83 : load-locals-quot ( args -- quot )
87 dup [ local-reader? ] contains? [
89 local-reader? [ 1array >r ] [ >r ] ?
92 length [ load-locals ] curry >quotation
96 : drop-locals-quot ( args -- quot )
100 length [ drop-locals ] curry
103 : point-free-body ( quot args -- newquot )
104 >r but-last-slice r> [ localize ] curry map concat ;
106 : point-free-end ( quot args -- newquot )
108 [ dup drop-locals-quot >r >r peek r> localize r> append ]
109 [ dup drop-locals-quot nip swap peek suffix ]
112 : (point-free) ( quot args -- newquot )
113 [ nip load-locals-quot ]
116 2tri 3append >quotation ;
118 : point-free ( quot args -- newquot )
120 [ nip length \ drop <repetition> >quotation ]
121 [ (point-free) ] if ;
123 UNION: lexical local local-reader local-writer local-word ;
125 GENERIC: free-vars* ( form -- )
127 : free-vars ( form -- vars )
128 [ free-vars* ] { } make prune ;
130 : add-if-free ( object -- )
132 { [ dup local-writer? ] [ "local-reader" word-prop , ] }
133 { [ dup lexical? ] [ , ] }
134 { [ dup quote? ] [ local>> , ] }
135 { [ t ] [ free-vars* ] }
138 M: object free-vars* drop ;
140 M: quotation free-vars* [ add-if-free ] each ;
143 [ vars>> ] [ body>> ] bi free-vars swap diff % ;
145 GENERIC: lambda-rewrite* ( obj -- )
147 GENERIC: local-rewrite* ( obj -- )
149 : lambda-rewrite ( quot -- quot' )
150 [ local-rewrite* ] [ ] make
151 [ [ lambda-rewrite* ] each ] [ ] make ;
153 UNION: block callable lambda ;
155 GENERIC: block-vars ( block -- seq )
157 GENERIC: block-body ( block -- quot )
159 M: callable block-vars drop { } ;
161 M: callable block-body ;
163 M: callable local-rewrite*
164 [ [ local-rewrite* ] each ] [ ] make , ;
166 M: lambda block-vars vars>> ;
168 M: lambda block-body body>> ;
170 M: lambda local-rewrite*
171 [ vars>> ] [ body>> ] bi
172 [ [ local-rewrite* ] each ] [ ] make <lambda> , ;
174 M: block lambda-rewrite*
175 #! Turn free variables into bound variables, curry them
177 dup free-vars [ <quote> ] map dup % [
178 over block-vars prepend
179 swap block-body [ [ lambda-rewrite* ] each ] [ ] make
181 ] keep length \ curry <repetition> % ;
183 M: object lambda-rewrite* , ;
185 M: object local-rewrite* , ;
187 : make-local ( name -- word )
190 dup <local-writer> dup name>> set
194 : make-locals ( seq -- words assoc )
195 [ [ make-local ] map ] H{ } make-assoc ;
197 : make-local-word ( name -- word )
198 <local-word> dup dup name>> set ;
200 : push-locals ( assoc -- )
203 : pop-locals ( assoc -- )
208 : (parse-lambda) ( assoc end -- quot )
209 t in-lambda? [ parse-until ] with-variable
210 >quotation swap pop-locals ;
212 : parse-lambda ( -- lambda )
213 "|" parse-tokens make-locals dup push-locals
214 \ ] (parse-lambda) <lambda> ;
216 : parse-binding ( -- pair/f )
221 { "[" [ \ ] parse-until >quotation ] }
222 { "[|" [ parse-lambda ] }
226 : (parse-bindings) ( -- )
228 first2 >r make-local r> 2array ,
232 : parse-bindings ( -- bindings vars )
234 [ (parse-bindings) ] H{ } make-assoc
238 : parse-bindings* ( -- words assoc )
241 namespace push-locals
247 : (parse-wbindings) ( -- )
249 first2 >r make-local-word r> 2array ,
253 : parse-wbindings ( -- bindings vars )
255 [ (parse-wbindings) ] H{ } make-assoc
259 : let-rewrite ( body bindings -- )
261 >r 1array r> spin <lambda> [ call ] curry compose
262 ] assoc-each local-rewrite* \ call , ;
264 M: let local-rewrite*
265 [ body>> ] [ bindings>> ] bi let-rewrite ;
267 M: let* local-rewrite*
268 [ body>> ] [ bindings>> ] bi let-rewrite ;
270 M: wlet local-rewrite*
271 [ body>> ] [ bindings>> ] bi
272 [ [ ] curry ] assoc-map
275 : parse-locals ( -- vars assoc )
277 word [ over "declared-effect" set-word-prop ] when*
278 in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
280 : parse-locals-definition ( word -- word quot )
281 scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
282 2dup "lambda" set-word-prop
283 lambda-rewrite first ;
285 : (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
287 : (M::) ( -- word def )
289 [ parse-locals-definition ] with-method-definition ;
291 : parsed-lambda ( form -- )
292 in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
296 : [| parse-lambda parsed-lambda ; parsing
299 scan "|" assert= parse-bindings
300 \ ] (parse-lambda) <let> parsed-lambda ; parsing
303 scan "|" assert= parse-bindings*
304 \ ] (parse-lambda) <let*> parsed-lambda ; parsing
307 scan "|" assert= parse-wbindings
308 \ ] (parse-lambda) <wlet> parsed-lambda ; parsing
310 : :: (::) define ; parsing
312 : M:: (M::) define ; parsing
314 : MACRO:: (::) define-macro ; parsing
316 : MEMO:: (::) define-memoized ; parsing
320 ! Pretty-printing locals
323 : pprint-var ( var -- )
324 #! Prettyprint a read/write local as its writer, just like
325 #! in the input syntax: [| x! | ... x 3 + x! ]
327 "local-writer" word-prop
330 : pprint-vars ( vars -- ) [ pprint-var ] each ;
335 dup vars>> pprint-vars
337 f <inset body>> pprint-elements block>
341 : pprint-let ( let word -- )
343 [ body>> ] [ bindings>> ] bi
347 [ <block >r pprint-var r> pprint* block> ] assoc-each
350 <block pprint-elements block>
354 M: let pprint* \ [let pprint-let ;
356 M: wlet pprint* \ [wlet pprint-let ;
358 M: let* pprint* \ [let* pprint-let ;
360 PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
362 M: lambda-word definer drop \ :: \ ; ;
364 M: lambda-word definition
365 "lambda" word-prop body>> ;
367 M: lambda-word reset-word
368 [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
370 INTERSECTION: lambda-macro macro lambda-word ;
372 M: lambda-macro definer drop \ MACRO:: \ ; ;
374 M: lambda-macro definition
375 "lambda" word-prop body>> ;
377 M: lambda-macro reset-word
378 [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
380 INTERSECTION: lambda-method method-body lambda-word ;
382 M: lambda-method definer drop \ M:: \ ; ;
384 M: lambda-method definition
385 "lambda" word-prop body>> ;
387 M: lambda-method reset-word
388 [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
390 INTERSECTION: lambda-memoized memoized lambda-word ;
392 M: lambda-memoized definer drop \ MEMO:: \ ; ;
394 M: lambda-memoized definition
395 "lambda" word-prop body>> ;
397 M: lambda-memoized reset-word
398 [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
400 : method-stack-effect ( method -- effect )
401 dup "lambda" word-prop vars>>
402 swap "method-generic" word-prop stack-effect
403 dup [ effect-out ] when
406 M: lambda-method synopsis*
408 "method-class" word-prop pprint-word
409 "method-generic" word-prop pprint-word
410 method-stack-effect effect>string comment. ;