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< ( vlist -- len vec )
  21     [ length>> ] [ vector>> ] bi ; inline
  22
  23 : unshare ( len vec -- len vec' )
  24     clone [ set-length ] 2keep ; inline
  25
  26 PRIVATE>
  27
  28 M: vlist ppush
  29     >vlist<
  30     2dup length = [ unshare ] unless
  31     [ [ 1+ swap ] dip push ] keep vlist boa ;
  32
  33 ERROR: empty-vlist-error ;
  34
  35 M: vlist ppop
  36     [ empty-vlist-error ]
  37     [ [ length>> 1- ] [ vector>> ] bi vlist boa ] if-empty ;
  38
  39 M: vlist clone
  40     [ length>> ] [ vector>> >vector ] bi vlist boa ;
  41
  42 M: vlist equal?
  43     over vlist? [ sequence= ] [ 2drop f ] if ;
  44
  45 : >vlist ( seq -- vlist )
  46     [ length ] [ >vector ] bi vlist boa ; inline
  47
  48 M: vlist like
  49     drop dup vlist? [ >vlist ] unless ;
  50
  51 INSTANCE: vlist immutable-sequence
  52
  53 : VL{ \ } [ >vlist ] parse-literal ; parsing
  54
  55 M: vlist pprint-delims drop \ VL{ \ } ;
  56 M: vlist >pprint-sequence ;
  57 M: vlist pprint* pprint-object ;
  58
  59 TUPLE: valist { vlist vlist read-only } ;
  60
  61 : <valist> ( -- valist ) <vlist> valist boa ; inline
  62
  63 M: valist assoc-size vlist>> length 2/ ;
  64
  65 : valist-at ( key i array -- value ? )
  66     over 0 >= [
  67         3dup nth-unsafe = [
  68             [ 1+ ] dip nth-unsafe nip t
  69         ] [
  70             [ 2 - ] dip valist-at
  71         ] if
  72     ] [ 3drop f f ] if ; inline recursive
  73
  74 M: valist at*
  75     vlist>> >vlist< [ 2 - ] [ underlying>> ] bi* valist-at ;
  76
  77 M: valist new-at
  78     vlist>> ppush ppush valist boa ;
  79
  80 M: valist >alist vlist>> ;
  81
  82 : >valist ( assoc -- valist )
  83     >alist concat >vlist valist boa ; inline
  84
  85 M: valist assoc-like
  86     drop dup valist? [ >valist ] unless ;
  87
  88 INSTANCE: valist assoc
  89
  90 : VA{ \ } [ >valist ] parse-literal ; parsing
  91
  92 M: valist pprint-delims drop \ VA{ \ } ;
  93 M: valist >pprint-sequence >alist ;
  94 M: valist pprint* pprint-object ;