basis/locals/locals.factor

   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 ;
  11
  12 IN: locals
  13
  14 ! Inspired by
  15 ! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
  16
  17 <PRIVATE
  18
  19 TUPLE: lambda vars body ;
  20
  21 C: <lambda> lambda
  22
  23 TUPLE: binding-form bindings body ;
  24
  25 TUPLE: let < binding-form ;
  26
  27 C: <let> let
  28
  29 TUPLE: let* < binding-form ;
  30
  31 C: <let*> let*
  32
  33 TUPLE: wlet < binding-form ;
  34
  35 C: <wlet> wlet
  36
  37 M: lambda expand-macros clone [ expand-macros ] change-body ;
  38
  39 M: binding-form expand-macros
  40     clone
  41         [ [ expand-macros ] assoc-map ] change-bindings
  42         [ expand-macros ] change-body ;
  43
  44 PREDICATE: local < word "local?" word-prop ;
  45
  46 : <local> ( name -- word )
  47     #! Create a local variable identifier
  48     f <word>
  49     dup t "local?" set-word-prop
  50     dup { } { object } define-primitive ;
  51
  52 PREDICATE: local-word < word "local-word?" word-prop ;
  53
  54 : <local-word> ( name -- word )
  55     f <word> dup t "local-word?" set-word-prop ;
  56
  57 PREDICATE: local-reader < word "local-reader?" word-prop ;
  58
  59 : <local-reader> ( name -- word )
  60     f <word>
  61     dup t "local-reader?" set-word-prop
  62     dup { } { object } define-primitive ;
  63
  64 PREDICATE: local-writer < word "local-writer?" word-prop ;
  65
  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 ]
  72         [ nip ]
  73     } 2cleave ;
  74
  75 TUPLE: quote local ;
  76
  77 C: <quote> quote
  78
  79 : local-index ( obj args -- n )
  80     [ dup quote? [ local>> ] when eq? ] with find drop ;
  81
  82 : read-local-quot ( obj args -- quot )
  83     local-index 1+ [ get-local ] curry ;
  84
  85 : localize-writer ( obj args -- quot )
  86     >r "local-reader" word-prop r>
  87     read-local-quot [ set-local-value ] append ;
  88
  89 : localize ( obj args -- quot )
  90     {
  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 ] }
  98     } cond ;
  99
 100 UNION: special local quote local-word local-reader local-writer ;
 101
 102 : load-locals-quot ( args -- quot )
 103     [
 104         [ ]
 105     ] [
 106         dup [ local-reader? ] contains? [
 107             <reversed> [
 108                 local-reader? [ 1array >r ] [ >r ] ?
 109             ] map concat
 110         ] [
 111             length [ load-locals ] curry >quotation
 112         ] if
 113     ] if-empty ;
 114
 115 : drop-locals-quot ( args -- quot )
 116     [ [ ] ] [ length [ drop-locals ] curry ] if-empty ;
 117
 118 : point-free-body ( quot args -- newquot )
 119     >r but-last-slice r> [ localize ] curry map concat ;
 120
 121 : point-free-end ( quot args -- newquot )
 122     over peek special?
 123     [ dup drop-locals-quot >r >r peek r> localize r> append ]
 124     [ dup drop-locals-quot nip swap peek suffix ]
 125     if ;
 126
 127 : (point-free) ( quot args -- newquot )
 128     [ nip load-locals-quot ]
 129     [ point-free-body ]
 130     [ point-free-end ]
 131     2tri 3append >quotation ;
 132
 133 : point-free ( quot args -- newquot )
 134     over empty?
 135     [ nip length \ drop <repetition> >quotation ]
 136     [ (point-free) ] if ;
 137
 138 UNION: lexical local local-reader local-writer local-word ;
 139
 140 GENERIC: free-vars* ( form -- )
 141
 142 : free-vars ( form -- vars )
 143     [ free-vars* ] { } make prune ;
 144
 145 : add-if-free ( object -- )
 146   {
 147       { [ dup local-writer? ] [ "local-reader" word-prop , ] }
 148       { [ dup lexical? ]      [ , ] }
 149       { [ dup quote? ]        [ local>> , ] }
 150       { [ t ]                 [ free-vars* ] }
 151   } cond ;
 152
 153 M: object free-vars* drop ;
 154
 155 M: quotation free-vars* [ add-if-free ] each ;
 156
 157 M: lambda free-vars*
 158     [ vars>> ] [ body>> ] bi free-vars swap diff % ;
 159
 160 GENERIC: lambda-rewrite* ( obj -- )
 161
 162 GENERIC: local-rewrite* ( obj -- )
 163
 164 : lambda-rewrite ( form -- form' )
 165     expand-macros
 166     [ local-rewrite* ] [ ] make
 167     [ [ lambda-rewrite* ] each ] [ ] make ;
 168
 169 UNION: block callable lambda ;
 170
 171 GENERIC: block-vars ( block -- seq )
 172
 173 GENERIC: block-body ( block -- quot )
 174
 175 M: callable block-vars drop { } ;
 176
 177 M: callable block-body ;
 178
 179 M: callable local-rewrite*
 180     [ [ local-rewrite* ] each ] [ ] make , ;
 181
 182 M: lambda block-vars vars>> ;
 183
 184 M: lambda block-body body>> ;
 185
 186 M: lambda local-rewrite*
 187     [ vars>> ] [ body>> ] bi
 188     [ [ local-rewrite* ] each ] [ ] make <lambda> , ;
 189
 190 M: block lambda-rewrite*
 191     #! Turn free variables into bound variables, curry them
 192     #! onto the body
 193     dup free-vars [ <quote> ] map dup % [
 194         over block-vars prepend
 195         swap block-body [ [ lambda-rewrite* ] each ] [ ] make
 196         swap point-free ,
 197     ] keep length \ curry <repetition> % ;
 198
 199 M: object lambda-rewrite* , ;
 200
 201 M: object local-rewrite* , ;
 202
 203 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 204
 205 ! Broil is used to support locals in literals
 206
 207 DEFER: [broil]
 208 DEFER: [broil-hashtable]
 209 DEFER: [broil-tuple]
 210
 211 : broil-element ( obj -- quot )
 212   {
 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 ] }
 221   }
 222   cond ;
 223
 224 : [broil] ( seq -- quot )
 225   [ [ broil-element ] map concat >quotation ]
 226   [ length ]
 227   [        ]
 228   tri
 229   [ nsequence ] curry curry compose ;
 230
 231 MACRO: broil ( seq -- quot ) [broil] ;
 232
 233 : [broil-hashtable] ( hashtable -- quot )
 234   >alist
 235   [ [ broil-element ] map concat >quotation ]
 236   [ length ]
 237   [        ]
 238   tri
 239   [ nsequence >hashtable ] curry curry compose ;
 240
 241 MACRO: broil-hashtable ( hashtable -- quot ) [broil-hashtable] ;
 242
 243 : [broil-tuple] ( tuple -- quot )
 244   tuple>array
 245   [ [ broil-element ] map concat >quotation ]
 246   [ length ]
 247   [        ]
 248   tri
 249   [ nsequence >tuple ] curry curry compose ;
 250
 251 MACRO: broil-tuple ( tuple -- quot ) [broil-tuple] ;
 252
 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...
 255
 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] % ;
 260
 261 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 262
 263 : make-local ( name -- word )
 264     "!" ?tail [
 265         <local-reader>
 266         dup <local-writer> dup name>> set
 267     ] [ <local> ] if
 268     dup dup name>> set ;
 269
 270 : make-locals ( seq -- words assoc )
 271     [ [ make-local ] map ] H{ } make-assoc ;
 272
 273 : make-local-word ( name -- word )
 274     <local-word> dup dup name>> set ;
 275
 276 : push-locals ( assoc -- )
 277     use get push ;
 278
 279 : pop-locals ( assoc -- )
 280     use get delete ;
 281
 282 SYMBOL: in-lambda?
 283
 284 : (parse-lambda) ( assoc end -- quot )
 285     t in-lambda? [ parse-until ] with-variable
 286     >quotation swap pop-locals ;
 287
 288 : parse-lambda ( -- lambda )
 289     "|" parse-tokens make-locals dup push-locals
 290     \ ] (parse-lambda) <lambda> ;
 291
 292 : parse-binding ( -- pair/f )
 293     scan dup "|" = [
 294         drop f
 295     ] [
 296         scan {
 297             { "[" [ \ ] parse-until >quotation ] }
 298             { "[|" [ parse-lambda ] }
 299         } case 2array
 300     ] if ;
 301
 302 : (parse-bindings) ( -- )
 303     parse-binding [
 304         first2 >r make-local r> 2array ,
 305         (parse-bindings)
 306     ] when* ;
 307
 308 : parse-bindings ( -- bindings vars )
 309     [
 310         [ (parse-bindings) ] H{ } make-assoc
 311         dup push-locals
 312     ] { } make swap ;
 313
 314 : parse-bindings* ( -- words assoc )
 315     [
 316         [
 317             namespace push-locals
 318
 319             (parse-bindings)
 320         ] { } make-assoc
 321     ] { } make swap ;
 322
 323 : (parse-wbindings) ( -- )
 324     parse-binding [
 325         first2 >r make-local-word r> 2array ,
 326         (parse-wbindings)
 327     ] when* ;
 328
 329 : parse-wbindings ( -- bindings vars )
 330     [
 331         [ (parse-wbindings) ] H{ } make-assoc
 332         dup push-locals
 333     ] { } make swap ;
 334
 335 : let-rewrite ( body bindings -- )
 336     <reversed> [
 337         >r 1array r> spin <lambda> [ call ] curry compose
 338     ] assoc-each local-rewrite* \ call , ;
 339
 340 M: let local-rewrite*
 341     [ body>> ] [ bindings>> ] bi let-rewrite ;
 342
 343 M: let* local-rewrite*
 344     [ body>> ] [ bindings>> ] bi let-rewrite ;
 345
 346 M: wlet local-rewrite*
 347     [ body>> ] [ bindings>> ] bi
 348     [ [ ] curry ] assoc-map
 349     let-rewrite ;
 350
 351 : parse-locals ( -- vars assoc )
 352     ")" parse-effect
 353     word [ over "declared-effect" set-word-prop ] when*
 354     in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
 355
 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 ;
 360
 361 : (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
 362
 363 : (M::) ( -- word def )
 364     CREATE-METHOD
 365     [ parse-locals-definition ] with-method-definition ;
 366
 367 : parsed-lambda ( accum form -- accum )
 368     in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
 369
 370 PRIVATE>
 371
 372 : [| parse-lambda parsed-lambda ; parsing
 373
 374 : [let
 375     scan "|" assert= parse-bindings
 376     \ ] (parse-lambda) <let> parsed-lambda ; parsing
 377
 378 : [let*
 379     scan "|" assert= parse-bindings*
 380     \ ] (parse-lambda) <let*> parsed-lambda ; parsing
 381
 382 : [wlet
 383     scan "|" assert= parse-wbindings
 384     \ ] (parse-lambda) <wlet> parsed-lambda ; parsing
 385
 386 : :: (::) define ; parsing
 387
 388 : M:: (M::) define ; parsing
 389
 390 : MACRO:: (::) define-macro ; parsing
 391
 392 : MEMO:: (::) define-memoized ; parsing
 393
 394 <PRIVATE
 395
 396 ! Pretty-printing locals
 397 SYMBOL: |
 398
 399 : pprint-var ( var -- )
 400     #! Prettyprint a read/write local as its writer, just like
 401     #! in the input syntax: [| x! | ... x 3 + x! ]
 402     dup local-reader? [
 403         "local-writer" word-prop
 404     ] when pprint-word ;
 405
 406 : pprint-vars ( vars -- ) [ pprint-var ] each ;
 407
 408 M: lambda pprint*
 409     <flow
 410     \ [| pprint-word
 411     dup vars>> pprint-vars
 412     \ | pprint-word
 413     f <inset body>> pprint-elements block>
 414     \ ] pprint-word
 415     block> ;
 416
 417 : pprint-let ( let word -- )
 418     pprint-word
 419     [ body>> ] [ bindings>> ] bi
 420     \ | pprint-word
 421     t <inset
 422     <block
 423     [ <block >r pprint-var r> pprint* block> ] assoc-each
 424     block>
 425     \ | pprint-word
 426     <block pprint-elements block>
 427     block>
 428     \ ] pprint-word ;
 429
 430 M: let pprint* \ [let pprint-let ;
 431
 432 M: wlet pprint* \ [wlet pprint-let ;
 433
 434 M: let* pprint* \ [let* pprint-let ;
 435
 436 PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
 437
 438 M: lambda-word definer drop \ :: \ ; ;
 439
 440 M: lambda-word definition
 441     "lambda" word-prop body>> ;
 442
 443 M: lambda-word reset-word
 444     [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
 445
 446 INTERSECTION: lambda-macro macro lambda-word ;
 447
 448 M: lambda-macro definer drop \ MACRO:: \ ; ;
 449
 450 M: lambda-macro definition
 451     "lambda" word-prop body>> ;
 452
 453 M: lambda-macro reset-word
 454     [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
 455
 456 INTERSECTION: lambda-method method-body lambda-word ;
 457
 458 M: lambda-method definer drop \ M:: \ ; ;
 459
 460 M: lambda-method definition
 461     "lambda" word-prop body>> ;
 462
 463 M: lambda-method reset-word
 464     [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
 465
 466 INTERSECTION: lambda-memoized memoized lambda-word ;
 467
 468 M: lambda-memoized definer drop \ MEMO:: \ ; ;
 469
 470 M: lambda-memoized definition
 471     "lambda" word-prop body>> ;
 472
 473 M: lambda-memoized reset-word
 474     [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
 475
 476 : method-stack-effect ( method -- effect )
 477     dup "lambda" word-prop vars>>
 478     swap "method-generic" word-prop stack-effect
 479     dup [ out>> ] when
 480     <effect> ;
 481
 482 M: lambda-method synopsis*
 483     dup dup dup definer.
 484     "method-class" word-prop pprint-word
 485     "method-generic" word-prop pprint-word
 486     method-stack-effect effect>string comment. ;
 487
 488 PRIVATE>