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