basis/vlists/vlists.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays accessors sequences sequences.private
   4 persistent.sequences assocs persistent.assocs kernel math
   5 vectors parser prettyprint.custom ;
   6 IN: vlists
   7
   8 TUPLE: vlist
   9 { length array-capacity read-only }
  10 { vector vector read-only } ;
  11
  12 : <vlist> ( -- vlist ) 0 V{ } clone vlist boa ; inline
  13
  14 M: vlist length length>> ;
  15
  16 M: vlist nth-unsafe vector>> nth-unsafe ;
  17
  18 <PRIVATE
  19
  20 : >vlist< [ length>> ] [ vector>> ] bi ; inline
  21
  22 : unshare ( len vec -- len vec' )
  23     clone [ set-length ] 2keep ; inline
  24
  25 PRIVATE>
  26
  27 M: vlist ppush
  28     >vlist<
  29     2dup length = [ unshare ] unless
  30     [ [ 1+ swap ] dip push ] keep vlist boa ;
  31
  32 ERROR: empty-vlist-error ;
  33
  34 M: vlist ppop
  35     [ empty-vlist-error ]
  36     [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ;
  37
  38 M: vlist clone
  39     [ length>> ] [ vector>> >vector ] bi vlist boa ;
  40
  41 M: vlist equal?
  42     over vlist? [ sequence= ] [ 2drop f ] if ;
  43
  44 : >vlist ( seq -- vlist )
  45     [ length ] [ >vector ] bi vlist boa ; inline
  46
  47 M: vlist like
  48     drop dup vlist? [ >vlist ] unless ;
  49
  50 INSTANCE: vlist immutable-sequence
  51
  52 : VL{ \ } [ >vlist ] parse-literal ; parsing
  53
  54 M: vlist pprint-delims drop \ VL{ \ } ;
  55 M: vlist >pprint-sequence ;
  56 M: vlist pprint* pprint-object ;
  57
  58 TUPLE: valist { vlist vlist read-only } ;
  59
  60 : <valist> ( -- valist ) <vlist> valist boa ; inline
  61
  62 M: valist assoc-size vlist>> length 2/ ;
  63
  64 : valist-at ( key i array -- value ? )
  65     over 0 >= [
  66         3dup nth-unsafe = [
  67             [ 1+ ] dip nth-unsafe nip t
  68         ] [
  69             [ 2 - ] dip valist-at
  70         ] if
  71     ] [ 3drop f f ] if ; inline recursive
  72
  73 M: valist at*
  74     vlist>> >vlist< [ 2 - ] [ underlying>> ] bi* valist-at ;
  75
  76 M: valist new-at
  77     vlist>> ppush ppush valist boa ;
  78
  79 M: valist >alist vlist>> ;
  80
  81 : >valist ( assoc -- valist )
  82     >alist concat >vlist valist boa ; inline
  83
  84 M: valist assoc-like
  85     drop dup valist? [ >valist ] unless ;
  86
  87 INSTANCE: valist assoc
  88
  89 : VA{ \ } [ >valist ] parse-literal ; parsing
  90
  91 M: valist pprint-delims drop \ VA{ \ } ;
  92 M: valist >pprint-sequence >alist ;
  93 M: valist pprint* pprint-object ;