1 ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel namespaces make sequences sequences.private assocs
4 math vectors strings classes.tuple generalizations parser words
5 quotations debugger macros arrays macros splitting combinators
6 prettyprint.backend definitions prettyprint hashtables
7 prettyprint.sections sets sequences.private effects
8 effects.parser generic generic.parser compiler.units accessors
9 locals.backend memoize macros.expander lexer classes
10 stack-checker.known-words ;
14 ! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
18 TUPLE: lambda vars body ;
22 TUPLE: binding-form bindings body ;
24 TUPLE: let < binding-form ;
28 TUPLE: let* < binding-form ;
32 TUPLE: wlet < binding-form ;
36 M: lambda expand-macros clone [ expand-macros ] change-body ;
38 M: binding-form expand-macros
40 [ [ expand-macros ] assoc-map ] change-bindings
41 [ expand-macros ] change-body ;
43 PREDICATE: local < word "local?" word-prop ;
45 : <local> ( name -- word )
46 #! Create a local variable identifier
48 dup t "local?" set-word-prop
49 dup { } { object } define-primitive ;
51 PREDICATE: local-word < word "local-word?" word-prop ;
53 : <local-word> ( name -- word )
54 f <word> dup t "local-word?" set-word-prop ;
56 PREDICATE: local-reader < word "local-reader?" word-prop ;
58 : <local-reader> ( name -- word )
60 dup t "local-reader?" set-word-prop
61 dup { } { object } define-primitive ;
63 PREDICATE: local-writer < word "local-writer?" word-prop ;
65 : <local-writer> ( reader -- word )
66 dup name>> "!" append f <word> {
67 [ nip { object } { } define-primitive ]
68 [ nip t "local-writer?" set-word-prop ]
69 [ swap "local-reader" set-word-prop ]
70 [ "local-writer" set-word-prop ]
78 : local-index ( obj args -- n )
79 [ dup quote? [ local>> ] when eq? ] with find drop ;
81 : read-local-quot ( obj args -- quot )
82 local-index 1+ [ get-local ] curry ;
84 : localize-writer ( obj args -- quot )
85 >r "local-reader" word-prop r>
86 read-local-quot [ set-local-value ] append ;
88 : localize ( obj args -- quot )
90 { [ over local? ] [ read-local-quot ] }
91 { [ over quote? ] [ >r local>> r> read-local-quot ] }
92 { [ over local-word? ] [ read-local-quot [ call ] append ] }
93 { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
94 { [ over local-writer? ] [ localize-writer ] }
95 { [ over \ lambda eq? ] [ 2drop [ ] ] }
96 { [ t ] [ drop 1quotation ] }
99 UNION: special local quote local-word local-reader local-writer ;
101 : load-locals-quot ( args -- quot )
105 dup [ local-reader? ] contains? [
107 local-reader? [ 1array >r ] [ >r ] ?
110 length [ load-locals ] curry >quotation
114 : drop-locals-quot ( args -- quot )
115 [ [ ] ] [ length [ drop-locals ] curry ] if-empty ;
117 : point-free-body ( quot args -- newquot )
118 >r but-last-slice r> [ localize ] curry map concat ;
120 : point-free-end ( quot args -- newquot )
122 [ dup drop-locals-quot >r >r peek r> localize r> append ]
123 [ dup drop-locals-quot nip swap peek suffix ]
126 : (point-free) ( quot args -- newquot )
127 [ nip load-locals-quot ]
130 2tri 3append >quotation ;
132 : point-free ( quot args -- newquot )
134 [ nip length \ drop <repetition> >quotation ]
135 [ (point-free) ] if ;
137 UNION: lexical local local-reader local-writer local-word ;
139 GENERIC: free-vars* ( form -- )
141 : free-vars ( form -- vars )
142 [ free-vars* ] { } make prune ;
144 : add-if-free ( object -- )
146 { [ dup local-writer? ] [ "local-reader" word-prop , ] }
147 { [ dup lexical? ] [ , ] }
148 { [ dup quote? ] [ local>> , ] }
149 { [ t ] [ free-vars* ] }
152 M: object free-vars* drop ;
154 M: quotation free-vars* [ add-if-free ] each ;
157 [ vars>> ] [ body>> ] bi free-vars swap diff % ;
159 GENERIC: lambda-rewrite* ( obj -- )
161 GENERIC: local-rewrite* ( obj -- )
163 : lambda-rewrite ( form -- form' )
165 [ local-rewrite* ] [ ] make
166 [ [ lambda-rewrite* ] each ] [ ] make ;
168 UNION: block callable lambda ;
170 GENERIC: block-vars ( block -- seq )
172 GENERIC: block-body ( block -- quot )
174 M: callable block-vars drop { } ;
176 M: callable block-body ;
178 M: callable local-rewrite*
179 [ [ local-rewrite* ] each ] [ ] make , ;
181 M: lambda block-vars vars>> ;
183 M: lambda block-body body>> ;
185 M: lambda local-rewrite*
186 [ vars>> ] [ body>> ] bi
187 [ [ local-rewrite* ] each ] [ ] make <lambda> , ;
189 M: block lambda-rewrite*
190 #! Turn free variables into bound variables, curry them
192 dup free-vars [ <quote> ] map dup % [
193 over block-vars prepend
194 swap block-body [ [ lambda-rewrite* ] each ] [ ] make
196 ] keep length \ curry <repetition> % ;
198 GENERIC: rewrite-element ( obj -- )
200 : rewrite-elements ( seq -- )
201 [ rewrite-element ] each ;
203 : rewrite-sequence ( seq -- )
204 [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
206 M: array rewrite-element rewrite-sequence ;
208 M: vector rewrite-element rewrite-sequence ;
210 M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
212 M: tuple rewrite-element
213 [ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ;
215 M: local rewrite-element , ;
217 M: word rewrite-element literalize , ;
219 M: object rewrite-element , ;
221 M: array local-rewrite* rewrite-element ;
223 M: vector local-rewrite* rewrite-element ;
225 M: tuple local-rewrite* rewrite-element ;
227 M: hashtable local-rewrite* rewrite-element ;
229 M: object lambda-rewrite* , ;
231 M: object local-rewrite* , ;
233 : make-local ( name -- word )
236 dup <local-writer> dup name>> set
240 : make-locals ( seq -- words assoc )
241 [ [ make-local ] map ] H{ } make-assoc ;
243 : make-local-word ( name -- word )
244 <local-word> dup dup name>> set ;
246 : push-locals ( assoc -- )
249 : pop-locals ( assoc -- )
254 : (parse-lambda) ( assoc end -- quot )
255 t in-lambda? [ parse-until ] with-variable
256 >quotation swap pop-locals ;
258 : parse-lambda ( -- lambda )
259 "|" parse-tokens make-locals dup push-locals
260 \ ] (parse-lambda) <lambda> ;
262 : parse-binding ( -- pair/f )
267 { "[" [ \ ] parse-until >quotation ] }
268 { "[|" [ parse-lambda ] }
272 : (parse-bindings) ( -- )
274 first2 >r make-local r> 2array ,
278 : parse-bindings ( -- bindings vars )
280 [ (parse-bindings) ] H{ } make-assoc
284 : parse-bindings* ( -- words assoc )
287 namespace push-locals
293 : (parse-wbindings) ( -- )
295 first2 >r make-local-word r> 2array ,
299 : parse-wbindings ( -- bindings vars )
301 [ (parse-wbindings) ] H{ } make-assoc
305 : let-rewrite ( body bindings -- )
307 >r 1array r> spin <lambda> [ call ] curry compose
308 ] assoc-each local-rewrite* \ call , ;
310 M: let local-rewrite*
311 [ body>> ] [ bindings>> ] bi let-rewrite ;
313 M: let* local-rewrite*
314 [ body>> ] [ bindings>> ] bi let-rewrite ;
316 M: wlet local-rewrite*
317 [ body>> ] [ bindings>> ] bi
318 [ [ ] curry ] assoc-map
321 : parse-locals ( -- vars assoc )
323 word [ over "declared-effect" set-word-prop ] when*
324 in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
326 : parse-locals-definition ( word -- word quot )
327 scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
328 2dup "lambda" set-word-prop
329 lambda-rewrite first ;
331 : (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
333 : (M::) ( -- word def )
335 [ parse-locals-definition ] with-method-definition ;
337 : parsed-lambda ( accum form -- accum )
338 in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
342 : [| parse-lambda parsed-lambda ; parsing
345 scan "|" assert= parse-bindings
346 \ ] (parse-lambda) <let> parsed-lambda ; parsing
349 scan "|" assert= parse-bindings*
350 \ ] (parse-lambda) <let*> parsed-lambda ; parsing
353 scan "|" assert= parse-wbindings
354 \ ] (parse-lambda) <wlet> parsed-lambda ; parsing
356 : :: (::) define ; parsing
358 : M:: (M::) define ; parsing
360 : MACRO:: (::) define-macro ; parsing
362 : MEMO:: (::) define-memoized ; parsing
366 ! Pretty-printing locals
369 : pprint-var ( var -- )
370 #! Prettyprint a read/write local as its writer, just like
371 #! in the input syntax: [| x! | ... x 3 + x! ]
373 "local-writer" word-prop
376 : pprint-vars ( vars -- ) [ pprint-var ] each ;
381 dup vars>> pprint-vars
383 f <inset body>> pprint-elements block>
387 : pprint-let ( let word -- )
389 [ body>> ] [ bindings>> ] bi
393 [ <block >r pprint-var r> pprint* block> ] assoc-each
396 <block pprint-elements block>
400 M: let pprint* \ [let pprint-let ;
402 M: wlet pprint* \ [wlet pprint-let ;
404 M: let* pprint* \ [let* pprint-let ;
406 PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
408 M: lambda-word definer drop \ :: \ ; ;
410 M: lambda-word definition
411 "lambda" word-prop body>> ;
413 M: lambda-word reset-word
414 [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
416 INTERSECTION: lambda-macro macro lambda-word ;
418 M: lambda-macro definer drop \ MACRO:: \ ; ;
420 M: lambda-macro definition
421 "lambda" word-prop body>> ;
423 M: lambda-macro reset-word
424 [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
426 INTERSECTION: lambda-method method-body lambda-word ;
428 M: lambda-method definer drop \ M:: \ ; ;
430 M: lambda-method definition
431 "lambda" word-prop body>> ;
433 M: lambda-method reset-word
434 [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
436 INTERSECTION: lambda-memoized memoized lambda-word ;
438 M: lambda-memoized definer drop \ MEMO:: \ ; ;
440 M: lambda-memoized definition
441 "lambda" word-prop body>> ;
443 M: lambda-memoized reset-word
444 [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
446 : method-stack-effect ( method -- effect )
447 dup "lambda" word-prop vars>>
448 swap "method-generic" word-prop stack-effect
452 M: lambda-method synopsis*
454 "method-class" word-prop pprint-word
455 "method-generic" word-prop pprint-word
456 method-stack-effect effect>string comment. ;