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 PRIMITIVE: jit-compile ( quot -- )
  13 PRIMITIVE: quotation-code ( quot -- start end )
  14 PRIMITIVE: quotation-compiled? ( quot -- ? )
  15
  16 <PRIVATE
  17 PRIMITIVE: array>quotation ( array -- quot )
  18
  19 : uncurry ( curry -- obj quot )
  20     { curried } declare dup 2 slot swap 3 slot ; inline
  21
  22 : uncompose ( compose -- quot quot2 )
  23     { composed } declare dup 2 slot swap 3 slot ; inline
  24
  25 PRIVATE>
  26
  27 M: quotation call (call) ;
  28
  29 M: curried call uncurry call ;
  30
  31 M: composed call uncompose [ call ] dip call ;
  32
  33 M: wrapper equal?
  34     over wrapper? [ [ wrapped>> ] same? ] [ 2drop f ] if ;
  35
  36 UNION: callable quotation curried composed ;
  37
  38 M: callable equal?
  39     over callable? [ sequence= ] [ 2drop f ] if ;
  40
  41 M: quotation length array>> length ;
  42
  43 M: quotation nth-unsafe array>> nth-unsafe ;
  44
  45 : >quotation ( seq -- quot )
  46     >array array>quotation ; inline
  47
  48 M: callable like drop dup quotation? [ >quotation ] unless ;
  49
  50 INSTANCE: quotation immutable-sequence
  51
  52 : 1quotation ( obj -- quot ) 1array array>quotation ;
  53
  54 GENERIC: literalize ( obj -- wrapped )
  55
  56 M: object literalize ;
  57
  58 M: wrapper literalize <wrapper> ;
  59
  60 M: curried length quot>> length 1 + ;
  61
  62 M: curried nth
  63     over 0 =
  64     [ nip obj>> literalize ]
  65     [ [ 1 - ] dip quot>> nth ]
  66     if ;
  67
  68 INSTANCE: curried immutable-sequence
  69
  70 M: composed length
  71     [ first>> length ] [ second>> length ] bi + ;
  72
  73 M: composed virtual-exemplar first>> ;
  74
  75 M: composed virtual@
  76     2dup first>> length < [
  77         first>>
  78     ] [
  79         [ first>> length - ] [ second>> ] bi
  80     ] if ;
  81
  82 INSTANCE: composed virtual-sequence