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