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 vectors strings classes.tuple generalizations
5 parser words quotations debugger macros arrays macros splitting
6 combinators prettyprint.backend definitions prettyprint
7 hashtables prettyprint.sections sets sequences.private effects
8 effects.parser generic generic.parser compiler.units accessors
9 locals.backend memoize macros.expander lexer
10 stack-checker.known-words ;
15 ! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
19 TUPLE: lambda vars body ;
23 TUPLE: binding-form bindings body ;
25 TUPLE: let < binding-form ;
29 TUPLE: let* < binding-form ;
33 TUPLE: wlet < binding-form ;
37 M: lambda expand-macros clone [ expand-macros ] change-body ;
39 M: binding-form expand-macros
41 [ [ expand-macros ] assoc-map ] change-bindings
42 [ expand-macros ] change-body ;
44 PREDICATE: local < word "local?" word-prop ;
46 : <local> ( name -- word )
47 #! Create a local variable identifier
49 dup t "local?" set-word-prop
50 dup { } { object } define-primitive ;
52 PREDICATE: local-word < word "local-word?" word-prop ;
54 : <local-word> ( name -- word )
55 f <word> dup t "local-word?" set-word-prop ;
57 PREDICATE: local-reader < word "local-reader?" word-prop ;
59 : <local-reader> ( name -- word )
61 dup t "local-reader?" set-word-prop
62 dup { } { object } define-primitive ;
64 PREDICATE: local-writer < word "local-writer?" word-prop ;
66 : <local-writer> ( reader -- word )
67 dup name>> "!" append f <word> {
68 [ nip { object } { } define-primitive ]
69 [ nip t "local-writer?" set-word-prop ]
70 [ swap "local-reader" set-word-prop ]
71 [ "local-writer" set-word-prop ]
79 : local-index ( obj args -- n )
80 [ dup quote? [ local>> ] when eq? ] with find drop ;
82 : read-local-quot ( obj args -- quot )
83 local-index 1+ [ get-local ] curry ;
85 : localize-writer ( obj args -- quot )
86 >r "local-reader" word-prop r>
87 read-local-quot [ set-local-value ] append ;
89 : localize ( obj args -- quot )
91 { [ over local? ] [ read-local-quot ] }
92 { [ over quote? ] [ >r local>> r> read-local-quot ] }
93 { [ over local-word? ] [ read-local-quot [ call ] append ] }
94 { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
95 { [ over local-writer? ] [ localize-writer ] }
96 { [ over \ lambda eq? ] [ 2drop [ ] ] }
97 { [ t ] [ drop 1quotation ] }
100 UNION: special local quote local-word local-reader local-writer ;
102 : load-locals-quot ( args -- quot )
106 dup [ local-reader? ] contains? [
108 local-reader? [ 1array >r ] [ >r ] ?
111 length [ load-locals ] curry >quotation
115 : drop-locals-quot ( args -- quot )
116 [ [ ] ] [ length [ drop-locals ] curry ] if-empty ;
118 : point-free-body ( quot args -- newquot )
119 >r but-last-slice r> [ localize ] curry map concat ;
121 : point-free-end ( quot args -- newquot )
123 [ dup drop-locals-quot >r >r peek r> localize r> append ]
124 [ dup drop-locals-quot nip swap peek suffix ]
127 : (point-free) ( quot args -- newquot )
128 [ nip load-locals-quot ]
131 2tri 3append >quotation ;
133 : point-free ( quot args -- newquot )
135 [ nip length \ drop <repetition> >quotation ]
136 [ (point-free) ] if ;
138 UNION: lexical local local-reader local-writer local-word ;
140 GENERIC: free-vars* ( form -- )
142 : free-vars ( form -- vars )
143 [ free-vars* ] { } make prune ;
145 : add-if-free ( object -- )
147 { [ dup local-writer? ] [ "local-reader" word-prop , ] }
148 { [ dup lexical? ] [ , ] }
149 { [ dup quote? ] [ local>> , ] }
150 { [ t ] [ free-vars* ] }
153 M: object free-vars* drop ;
155 M: quotation free-vars* [ add-if-free ] each ;
158 [ vars>> ] [ body>> ] bi free-vars swap diff % ;
160 GENERIC: lambda-rewrite* ( obj -- )
162 GENERIC: local-rewrite* ( obj -- )
164 : lambda-rewrite ( form -- form' )
166 [ local-rewrite* ] [ ] make
167 [ [ lambda-rewrite* ] each ] [ ] make ;
169 UNION: block callable lambda ;
171 GENERIC: block-vars ( block -- seq )
173 GENERIC: block-body ( block -- quot )
175 M: callable block-vars drop { } ;
177 M: callable block-body ;
179 M: callable local-rewrite*
180 [ [ local-rewrite* ] each ] [ ] make , ;
182 M: lambda block-vars vars>> ;
184 M: lambda block-body body>> ;
186 M: lambda local-rewrite*
187 [ vars>> ] [ body>> ] bi
188 [ [ local-rewrite* ] each ] [ ] make <lambda> , ;
190 M: block lambda-rewrite*
191 #! Turn free variables into bound variables, curry them
193 dup free-vars [ <quote> ] map dup % [
194 over block-vars prepend
195 swap block-body [ [ lambda-rewrite* ] each ] [ ] make
197 ] keep length \ curry <repetition> % ;
199 M: object lambda-rewrite* , ;
201 M: object local-rewrite* , ;
203 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
205 ! Broil is used to support locals in literals
208 DEFER: [broil-hashtable]
211 : broil-element ( obj -- quot )
213 { [ dup number? ] [ 1quotation ] }
214 { [ dup string? ] [ 1quotation ] }
215 { [ dup sequence? ] [ [broil] ] }
216 { [ dup hashtable? ] [ [broil-hashtable] ] }
217 { [ dup tuple? ] [ [broil-tuple] ] }
218 { [ dup local? ] [ 1quotation ] }
219 { [ dup word? ] [ literalize 1quotation ] }
220 { [ t ] [ 1quotation ] }
224 : [broil] ( seq -- quot )
225 [ [ broil-element ] map concat >quotation ]
229 [ nsequence ] curry curry compose ;
231 MACRO: broil ( seq -- quot ) [broil] ;
233 : [broil-hashtable] ( hashtable -- quot )
235 [ [ broil-element ] map concat >quotation ]
239 [ nsequence >hashtable ] curry curry compose ;
241 MACRO: broil-hashtable ( hashtable -- quot ) [broil-hashtable] ;
243 : [broil-tuple] ( tuple -- quot )
245 [ [ broil-element ] map concat >quotation ]
249 [ nsequence >tuple ] curry curry compose ;
251 MACRO: broil-tuple ( tuple -- quot ) [broil-tuple] ;
253 ! Engage broil on arrays and vectors. Can't do it on 'sequence'
254 ! because that will pick up strings and integers. What do do...
256 M: array local-rewrite* ( array -- ) [broil] % ;
257 M: vector local-rewrite* ( vector -- ) [broil] % ;
258 M: tuple local-rewrite* ( tuple -- ) [broil-tuple] % ;
259 M: hashtable local-rewrite* ( hashtable -- ) [broil-hashtable] % ;
261 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
263 : make-local ( name -- word )
266 dup <local-writer> dup name>> set
270 : make-locals ( seq -- words assoc )
271 [ [ make-local ] map ] H{ } make-assoc ;
273 : make-local-word ( name -- word )
274 <local-word> dup dup name>> set ;
276 : push-locals ( assoc -- )
279 : pop-locals ( assoc -- )
284 : (parse-lambda) ( assoc end -- quot )
285 t in-lambda? [ parse-until ] with-variable
286 >quotation swap pop-locals ;
288 : parse-lambda ( -- lambda )
289 "|" parse-tokens make-locals dup push-locals
290 \ ] (parse-lambda) <lambda> ;
292 : parse-binding ( -- pair/f )
297 { "[" [ \ ] parse-until >quotation ] }
298 { "[|" [ parse-lambda ] }
302 : (parse-bindings) ( -- )
304 first2 >r make-local r> 2array ,
308 : parse-bindings ( -- bindings vars )
310 [ (parse-bindings) ] H{ } make-assoc
314 : parse-bindings* ( -- words assoc )
317 namespace push-locals
323 : (parse-wbindings) ( -- )
325 first2 >r make-local-word r> 2array ,
329 : parse-wbindings ( -- bindings vars )
331 [ (parse-wbindings) ] H{ } make-assoc
335 : let-rewrite ( body bindings -- )
337 >r 1array r> spin <lambda> [ call ] curry compose
338 ] assoc-each local-rewrite* \ call , ;
340 M: let local-rewrite*
341 [ body>> ] [ bindings>> ] bi let-rewrite ;
343 M: let* local-rewrite*
344 [ body>> ] [ bindings>> ] bi let-rewrite ;
346 M: wlet local-rewrite*
347 [ body>> ] [ bindings>> ] bi
348 [ [ ] curry ] assoc-map
351 : parse-locals ( -- vars assoc )
353 word [ over "declared-effect" set-word-prop ] when*
354 in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
356 : parse-locals-definition ( word -- word quot )
357 scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
358 2dup "lambda" set-word-prop
359 lambda-rewrite first ;
361 : (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
363 : (M::) ( -- word def )
365 [ parse-locals-definition ] with-method-definition ;
367 : parsed-lambda ( accum form -- accum )
368 in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
372 : [| parse-lambda parsed-lambda ; parsing
375 scan "|" assert= parse-bindings
376 \ ] (parse-lambda) <let> parsed-lambda ; parsing
379 scan "|" assert= parse-bindings*
380 \ ] (parse-lambda) <let*> parsed-lambda ; parsing
383 scan "|" assert= parse-wbindings
384 \ ] (parse-lambda) <wlet> parsed-lambda ; parsing
386 : :: (::) define ; parsing
388 : M:: (M::) define ; parsing
390 : MACRO:: (::) define-macro ; parsing
392 : MEMO:: (::) define-memoized ; parsing
396 ! Pretty-printing locals
399 : pprint-var ( var -- )
400 #! Prettyprint a read/write local as its writer, just like
401 #! in the input syntax: [| x! | ... x 3 + x! ]
403 "local-writer" word-prop
406 : pprint-vars ( vars -- ) [ pprint-var ] each ;
411 dup vars>> pprint-vars
413 f <inset body>> pprint-elements block>
417 : pprint-let ( let word -- )
419 [ body>> ] [ bindings>> ] bi
423 [ <block >r pprint-var r> pprint* block> ] assoc-each
426 <block pprint-elements block>
430 M: let pprint* \ [let pprint-let ;
432 M: wlet pprint* \ [wlet pprint-let ;
434 M: let* pprint* \ [let* pprint-let ;
436 PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
438 M: lambda-word definer drop \ :: \ ; ;
440 M: lambda-word definition
441 "lambda" word-prop body>> ;
443 M: lambda-word reset-word
444 [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
446 INTERSECTION: lambda-macro macro lambda-word ;
448 M: lambda-macro definer drop \ MACRO:: \ ; ;
450 M: lambda-macro definition
451 "lambda" word-prop body>> ;
453 M: lambda-macro reset-word
454 [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
456 INTERSECTION: lambda-method method-body lambda-word ;
458 M: lambda-method definer drop \ M:: \ ; ;
460 M: lambda-method definition
461 "lambda" word-prop body>> ;
463 M: lambda-method reset-word
464 [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
466 INTERSECTION: lambda-memoized memoized lambda-word ;
468 M: lambda-memoized definer drop \ MEMO:: \ ; ;
470 M: lambda-memoized definition
471 "lambda" word-prop body>> ;
473 M: lambda-memoized reset-word
474 [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
476 : method-stack-effect ( method -- effect )
477 dup "lambda" word-prop vars>>
478 swap "method-generic" word-prop stack-effect
482 M: lambda-method synopsis*
484 "method-class" word-prop pprint-word
485 "method-generic" word-prop pprint-word
486 method-stack-effect effect>string comment. ;