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 inference.transforms parser words quotations debugger macros
   5 arrays macros splitting combinators prettyprint.backend
   6 definitions prettyprint hashtables prettyprint.sections sets
   7 sequences.private effects effects.parser generic generic.parser
   8 compiler.units accessors locals.backend memoize lexer ;
   9 IN: locals
  10
  11 ! Inspired by
  12 ! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
  13
  14 <PRIVATE
  15
  16 TUPLE: lambda vars body ;
  17
  18 C: <lambda> lambda
  19
  20 TUPLE: let bindings body ;
  21
  22 C: <let> let
  23
  24 TUPLE: let* bindings body ;
  25
  26 C: <let*> let*
  27
  28 TUPLE: wlet bindings body ;
  29
  30 C: <wlet> wlet
  31
  32 PREDICATE: local < word "local?" word-prop ;
  33
  34 : <local> ( name -- word )
  35     #! Create a local variable identifier
  36     f <word> dup t "local?" set-word-prop ;
  37
  38 PREDICATE: local-word < word "local-word?" word-prop ;
  39
  40 : <local-word> ( name -- word )
  41     f <word> dup t "local-word?" set-word-prop ;
  42
  43 PREDICATE: local-reader < word "local-reader?" word-prop ;
  44
  45 : <local-reader> ( name -- word )
  46     f <word> dup t "local-reader?" set-word-prop ;
  47
  48 PREDICATE: local-writer < word "local-writer?" word-prop ;
  49
  50 : <local-writer> ( reader -- word )
  51     dup name>> "!" append f <word>
  52     [ t "local-writer?" set-word-prop ] keep
  53     [ "local-writer" set-word-prop ] 2keep
  54     [ swap "local-reader" set-word-prop ] keep ;
  55
  56 TUPLE: quote local ;
  57
  58 C: <quote> quote
  59
  60 : local-index ( obj args -- n )
  61     [ dup quote? [ quote-local ] when eq? ] with find drop ;
  62
  63 : read-local-quot ( obj args -- quot )
  64     local-index 1+ [ get-local ] curry ;
  65
  66 : localize-writer ( obj args -- quot )
  67     >r "local-reader" word-prop r>
  68     read-local-quot [ set-local-value ] append ;
  69
  70 : localize ( obj args -- quot )
  71     {
  72         { [ over local? ]        [ read-local-quot ] }
  73         { [ over quote? ]        [ >r quote-local r> read-local-quot ] }
  74         { [ over local-word? ]   [ read-local-quot [ call ] append ] }
  75         { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
  76         { [ over local-writer? ] [ localize-writer ] }
  77         { [ over \ lambda eq? ]  [ 2drop [ ] ] }
  78         { [ t ]                  [ drop 1quotation ] }
  79     } cond ;
  80
  81 UNION: special local quote local-word local-reader local-writer ;
  82
  83 : load-locals-quot ( args -- quot )
  84     dup empty? [
  85         drop [ ]
  86     ] [
  87         dup [ local-reader? ] contains? [
  88             <reversed> [
  89                 local-reader? [ 1array >r ] [ >r ] ?
  90             ] map concat
  91         ] [
  92             length [ load-locals ] curry >quotation
  93         ] if
  94     ] if ;
  95
  96 : drop-locals-quot ( args -- quot )
  97     dup empty? [
  98         drop [ ]
  99     ] [
 100         length [ drop-locals ] curry
 101     ] if ;
 102
 103 : point-free-body ( quot args -- newquot )
 104     >r but-last-slice r> [ localize ] curry map concat ;
 105
 106 : point-free-end ( quot args -- newquot )
 107     over peek special?
 108     [ dup drop-locals-quot >r >r peek r> localize r> append ]
 109     [ dup drop-locals-quot nip swap peek suffix ]
 110     if ;
 111
 112 : (point-free) ( quot args -- newquot )
 113     [ nip load-locals-quot ]
 114     [ point-free-body ]
 115     [ point-free-end ]
 116     2tri 3append >quotation ;
 117
 118 : point-free ( quot args -- newquot )
 119     over empty?
 120     [ nip length \ drop <repetition> >quotation ]
 121     [ (point-free) ] if ;
 122
 123 UNION: lexical local local-reader local-writer local-word ;
 124
 125 GENERIC: free-vars* ( form -- )
 126
 127 : free-vars ( form -- vars )
 128     [ free-vars* ] { } make prune ;
 129
 130 : add-if-free ( object -- )
 131   {
 132       { [ dup local-writer? ] [ "local-reader" word-prop , ] }
 133       { [ dup lexical? ]      [ , ] }
 134       { [ dup quote? ]        [ local>> , ] }
 135       { [ t ]                 [ free-vars* ] }
 136   } cond ;
 137
 138 M: object free-vars* drop ;
 139
 140 M: quotation free-vars* [ add-if-free ] each ;
 141
 142 M: lambda free-vars*
 143     [ vars>> ] [ body>> ] bi free-vars swap diff % ;
 144
 145 GENERIC: lambda-rewrite* ( obj -- )
 146
 147 GENERIC: local-rewrite* ( obj -- )
 148
 149 : lambda-rewrite ( quot -- quot' )
 150     [ local-rewrite* ] [ ] make
 151     [ [ lambda-rewrite* ] each ] [ ] make ;
 152
 153 UNION: block callable lambda ;
 154
 155 GENERIC: block-vars ( block -- seq )
 156
 157 GENERIC: block-body ( block -- quot )
 158
 159 M: callable block-vars drop { } ;
 160
 161 M: callable block-body ;
 162
 163 M: callable local-rewrite*
 164     [ [ local-rewrite* ] each ] [ ] make , ;
 165
 166 M: lambda block-vars vars>> ;
 167
 168 M: lambda block-body body>> ;
 169
 170 M: lambda local-rewrite*
 171     [ vars>> ] [ body>> ] bi
 172     [ [ local-rewrite* ] each ] [ ] make <lambda> , ;
 173
 174 M: block lambda-rewrite*
 175     #! Turn free variables into bound variables, curry them
 176     #! onto the body
 177     dup free-vars [ <quote> ] map dup % [
 178         over block-vars prepend
 179         swap block-body [ [ lambda-rewrite* ] each ] [ ] make
 180         swap point-free ,
 181     ] keep length \ curry <repetition> % ;
 182
 183 M: object lambda-rewrite* , ;
 184
 185 M: object local-rewrite* , ;
 186
 187 : make-local ( name -- word )
 188     "!" ?tail [
 189         <local-reader>
 190         dup <local-writer> dup name>> set
 191     ] [ <local> ] if
 192     dup dup name>> set ;
 193
 194 : make-locals ( seq -- words assoc )
 195     [ [ make-local ] map ] H{ } make-assoc ;
 196
 197 : make-local-word ( name -- word )
 198     <local-word> dup dup name>> set ;
 199
 200 : push-locals ( assoc -- )
 201     use get push ;
 202
 203 : pop-locals ( assoc -- )
 204     use get delete ;
 205
 206 SYMBOL: in-lambda?
 207
 208 : (parse-lambda) ( assoc end -- quot )
 209     t in-lambda? [ parse-until ] with-variable
 210     >quotation swap pop-locals ;
 211
 212 : parse-lambda ( -- lambda )
 213     "|" parse-tokens make-locals dup push-locals
 214     \ ] (parse-lambda) <lambda> ;
 215
 216 : parse-binding ( -- pair/f )
 217     scan dup "|" = [
 218         drop f
 219     ] [
 220         scan {
 221             { "[" [ \ ] parse-until >quotation ] }
 222             { "[|" [ parse-lambda ] }
 223         } case 2array
 224     ] if ;
 225
 226 : (parse-bindings) ( -- )
 227     parse-binding [
 228         first2 >r make-local r> 2array ,
 229         (parse-bindings)
 230     ] when* ;
 231
 232 : parse-bindings ( -- bindings vars )
 233     [
 234         [ (parse-bindings) ] H{ } make-assoc
 235         dup push-locals
 236     ] { } make swap ;
 237
 238 : parse-bindings* ( -- words assoc )
 239     [
 240         [
 241             namespace push-locals
 242
 243             (parse-bindings)
 244         ] { } make-assoc
 245     ] { } make swap ;
 246
 247 : (parse-wbindings) ( -- )
 248     parse-binding [
 249         first2 >r make-local-word r> 2array ,
 250         (parse-wbindings)
 251     ] when* ;
 252
 253 : parse-wbindings ( -- bindings vars )
 254     [
 255         [ (parse-wbindings) ] H{ } make-assoc
 256         dup push-locals
 257     ] { } make swap ;
 258
 259 : let-rewrite ( body bindings -- )
 260     <reversed> [
 261         >r 1array r> spin <lambda> [ call ] curry compose
 262     ] assoc-each local-rewrite* \ call , ;
 263
 264 M: let local-rewrite*
 265     [ body>> ] [ bindings>> ] bi let-rewrite ;
 266
 267 M: let* local-rewrite*
 268     [ body>> ] [ bindings>> ] bi let-rewrite ;
 269
 270 M: wlet local-rewrite*
 271     [ body>> ] [ bindings>> ] bi
 272     [ [ ] curry ] assoc-map
 273     let-rewrite ;
 274
 275 : parse-locals ( -- vars assoc )
 276     ")" parse-effect
 277     word [ over "declared-effect" set-word-prop ] when*
 278     in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
 279
 280 : parse-locals-definition ( word -- word quot )
 281     scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
 282     2dup "lambda" set-word-prop
 283     lambda-rewrite first ;
 284
 285 : (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
 286
 287 : (M::) ( -- word def )
 288     CREATE-METHOD
 289     [ parse-locals-definition ] with-method-definition ;
 290
 291 : parsed-lambda ( form -- )
 292     in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
 293
 294 PRIVATE>
 295
 296 : [| parse-lambda parsed-lambda ; parsing
 297
 298 : [let
 299     scan "|" assert= parse-bindings
 300     \ ] (parse-lambda) <let> parsed-lambda ; parsing
 301
 302 : [let*
 303     scan "|" assert= parse-bindings*
 304     \ ] (parse-lambda) <let*> parsed-lambda ; parsing
 305
 306 : [wlet
 307     scan "|" assert= parse-wbindings
 308     \ ] (parse-lambda) <wlet> parsed-lambda ; parsing
 309
 310 : :: (::) define ; parsing
 311
 312 : M:: (M::) define ; parsing
 313
 314 : MACRO:: (::) define-macro ; parsing
 315
 316 : MEMO:: (::) define-memoized ; parsing
 317
 318 <PRIVATE
 319
 320 ! Pretty-printing locals
 321 SYMBOL: |
 322
 323 : pprint-var ( var -- )
 324     #! Prettyprint a read/write local as its writer, just like
 325     #! in the input syntax: [| x! | ... x 3 + x! ]
 326     dup local-reader? [
 327         "local-writer" word-prop
 328     ] when pprint-word ;
 329
 330 : pprint-vars ( vars -- ) [ pprint-var ] each ;
 331
 332 M: lambda pprint*
 333     <flow
 334     \ [| pprint-word
 335     dup vars>> pprint-vars
 336     \ | pprint-word
 337     f <inset body>> pprint-elements block>
 338     \ ] pprint-word
 339     block> ;
 340
 341 : pprint-let ( let word -- )
 342     pprint-word
 343     [ body>> ] [ bindings>> ] bi
 344     \ | pprint-word
 345     t <inset
 346     <block
 347     [ <block >r pprint-var r> pprint* block> ] assoc-each
 348     block>
 349     \ | pprint-word
 350     <block pprint-elements block>
 351     block>
 352     \ ] pprint-word ;
 353
 354 M: let pprint* \ [let pprint-let ;
 355
 356 M: wlet pprint* \ [wlet pprint-let ;
 357
 358 M: let* pprint* \ [let* pprint-let ;
 359
 360 PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
 361
 362 M: lambda-word definer drop \ :: \ ; ;
 363
 364 M: lambda-word definition
 365     "lambda" word-prop body>> ;
 366
 367 M: lambda-word reset-word
 368     [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
 369
 370 INTERSECTION: lambda-macro macro lambda-word ;
 371
 372 M: lambda-macro definer drop \ MACRO:: \ ; ;
 373
 374 M: lambda-macro definition
 375     "lambda" word-prop body>> ;
 376
 377 M: lambda-macro reset-word
 378     [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
 379
 380 INTERSECTION: lambda-method method-body lambda-word ;
 381
 382 M: lambda-method definer drop \ M:: \ ; ;
 383
 384 M: lambda-method definition
 385     "lambda" word-prop body>> ;
 386
 387 M: lambda-method reset-word
 388     [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
 389
 390 INTERSECTION: lambda-memoized memoized lambda-word ;
 391
 392 M: lambda-memoized definer drop \ MEMO:: \ ; ;
 393
 394 M: lambda-memoized definition
 395     "lambda" word-prop body>> ;
 396
 397 M: lambda-memoized reset-word
 398     [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
 399
 400 : method-stack-effect ( method -- effect )
 401     dup "lambda" word-prop vars>>
 402     swap "method-generic" word-prop stack-effect
 403     dup [ effect-out ] when
 404     <effect> ;
 405
 406 M: lambda-method synopsis*
 407     dup dup dup definer.
 408     "method-class" word-prop pprint-word
 409     "method-generic" word-prop pprint-word
 410     method-stack-effect effect>string comment. ;
 411
 412 PRIVATE>