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 kernel kernel.private math sequences
   4 sequences.private slots.private ;
   5 IN: quotations
   6
   7 BUILTIN: quotation
   8     { array array read-only initial: { } }
   9     cached-effect
  10     cache-counter ;
  11
  12 <PRIVATE
  13
  14 : uncurry ( curry -- obj quot )
  15     { curry } declare dup 2 slot swap 3 slot ; inline
  16
  17 : uncompose ( compose -- quot quot2 )
  18     { compose } declare dup 2 slot swap 3 slot ; inline
  19
  20 PRIVATE>
  21
  22 M: quotation call (call) ;
  23
  24 M: curry call uncurry call ;
  25
  26 M: compose call uncompose [ call ] dip call ;
  27
  28 M: wrapper equal?
  29     over wrapper? [ [ wrapped>> ] same? ] [ 2drop f ] if ;
  30
  31 UNION: callable quotation curry compose ;
  32
  33 M: callable equal?
  34     over callable? [ sequence= ] [ 2drop f ] if ;
  35
  36 M: quotation length array>> length ;
  37
  38 M: quotation nth-unsafe array>> nth-unsafe ;
  39
  40 : >quotation ( seq -- quot )
  41     >array array>quotation ; inline
  42
  43 M: callable like drop dup quotation? [ >quotation ] unless ;
  44
  45 INSTANCE: quotation immutable-sequence
  46
  47 : 1quotation ( obj -- quot ) 1array >quotation ;
  48
  49 GENERIC: literalize ( obj -- wrapped )
  50
  51 M: object literalize ;
  52
  53 M: wrapper literalize <wrapper> ;
  54
  55 M: curry length quot>> length 1 + ;
  56
  57 M: curry nth
  58     over 0 =
  59     [ nip obj>> literalize ]
  60     [ [ 1 - ] dip quot>> nth ]
  61     if ;
  62
  63 INSTANCE: curry immutable-sequence
  64
  65 M: compose length
  66     [ first>> length ] [ second>> length ] bi + ;
  67
  68 M: compose virtual-exemplar first>> ;
  69
  70 M: compose virtual@
  71     2dup first>> length < [
  72         first>>
  73     ] [
  74         [ first>> length - ] [ second>> ] bi
  75     ] if ;
  76
  77 INSTANCE: compose virtual-sequence