core/quotations/quotations.factor

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