core/quotations/quotations.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays sequences sequences.private
   4 kernel kernel.private math assocs quotations.private
   5 slots.private ;
   6 IN: quotations
   7
   8 <PRIVATE
   9
  10 : uncurry ( curry -- obj quot )
  11     { curry } declare dup 2 slot swap 3 slot ; inline
  12
  13 : uncompose ( compose -- quot quot2 )
  14     { compose } declare dup 2 slot swap 3 slot ; inline
  15
  16 PRIVATE>
  17
  18 M: quotation call (call) ;
  19
  20 M: curry call uncurry call ;
  21
  22 M: compose call uncompose [ call ] dip call ;
  23
  24 M: wrapper equal?
  25     over wrapper? [ [ wrapped>> ] same? ] [ 2drop f ] if ;
  26
  27 UNION: callable quotation curry compose ;
  28
  29 M: callable equal?
  30     over callable? [ sequence= ] [ 2drop f ] if ;
  31
  32 M: quotation length array>> length ;
  33
  34 M: quotation nth-unsafe array>> nth-unsafe ;
  35
  36 : >quotation ( seq -- quot )
  37     >array array>quotation ; inline
  38
  39 M: callable like drop dup quotation? [ >quotation ] unless ;
  40
  41 INSTANCE: quotation immutable-sequence
  42
  43 : 1quotation ( obj -- quot ) 1array >quotation ;
  44
  45 GENERIC: literalize ( obj -- wrapped )
  46
  47 M: object literalize ;
  48
  49 M: wrapper literalize <wrapper> ;
  50
  51 M: curry length quot>> length 1 + ;
  52
  53 M: curry nth
  54     over 0 =
  55     [ nip obj>> literalize ]
  56     [ [ 1 - ] dip quot>> nth ]
  57     if ;
  58
  59 INSTANCE: curry immutable-sequence
  60
  61 M: compose length
  62     [ first>> length ] [ second>> length ] bi + ;
  63
  64 M: compose virtual-exemplar first>> ;
  65
  66 M: compose virtual@
  67     2dup first>> length < [
  68         first>>
  69     ] [
  70         [ first>> length - ] [ second>> ] bi
  71     ] if ;
  72
  73 INSTANCE: compose virtual-sequence