git.gag.com Git - debian/gnuradio/blob - gruel/src/lib/pmt/pmt.cc

   1 /* -*- c++ -*- */
   2 /*
   3  * Copyright 2006,2009,2010 Free Software Foundation, Inc.
   4  *
   5  * This file is part of GNU Radio
   6  *
   7  * GNU Radio is free software; you can redistribute it and/or modify
   8  * it under the terms of the GNU General Public License as published by
   9  * the Free Software Foundation; either version 3, or (at your option)
  10  * any later version.
  11  *
  12  * GNU Radio is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with GNU Radio; see the file COPYING.  If not, write to
  19  * the Free Software Foundation, Inc., 51 Franklin Street,
  20  * Boston, MA 02110-1301, USA.
  21  */
  22
  23 #ifdef HAVE_CONFIG_H
  24 #include <config.h>
  25 #endif
  26 #include <vector>
  27 #include <gruel/pmt.h>
  28 #include "pmt_int.h"
  29 #include <gruel/msg_accepter.h>
  30 #include <gruel/pmt_pool.h>
  31 #include <stdio.h>
  32 #include <string.h>
  33
  34 namespace pmt {
  35
  36 static const int CACHE_LINE_SIZE = 64;          // good guess
  37
  38 # if (PMT_LOCAL_ALLOCATOR)
  39
  40 static pmt_pool global_pmt_pool(sizeof(pmt_pair), CACHE_LINE_SIZE);
  41
  42 void *
  43 pmt_base::operator new(size_t size)
  44 {
  45   void *p = global_pmt_pool.malloc();
  46
  47   // fprintf(stderr, "pmt_base::new p = %p\n", p);
  48   assert((reinterpret_cast<intptr_t>(p) & (CACHE_LINE_SIZE - 1)) == 0);
  49   return p;
  50 }
  51
  52 void
  53 pmt_base::operator delete(void *p, size_t size)
  54 {
  55   global_pmt_pool.free(p);
  56 }
  57
  58 #endif
  59
  60 void intrusive_ptr_add_ref(pmt_base* p) { ++(p->count_); }
  61 void intrusive_ptr_release(pmt_base* p) { if (--(p->count_) == 0 ) delete p; }
  62
  63 pmt_base::~pmt_base()
  64 {
  65   // nop -- out of line virtual destructor
  66 }
  67
  68 ////////////////////////////////////////////////////////////////////////////
  69 //                         Exceptions
  70 ////////////////////////////////////////////////////////////////////////////
  71
  72 pmt_exception::pmt_exception(const std::string &msg, pmt_t obj)
  73   : logic_error(msg + ": " + pmt_write_string(obj))
  74 {
  75 }
  76
  77 pmt_wrong_type::pmt_wrong_type(const std::string &msg, pmt_t obj)
  78   : pmt_exception(msg + ": wrong_type ", obj)
  79 {
  80 }
  81
  82 pmt_out_of_range::pmt_out_of_range(const std::string &msg, pmt_t obj)
  83   : pmt_exception(msg + ": out of range ", obj)
  84 {
  85 }
  86
  87 pmt_notimplemented::pmt_notimplemented(const std::string &msg, pmt_t obj)
  88   : pmt_exception(msg + ": notimplemented ", obj)
  89 {
  90 }
  91
  92 ////////////////////////////////////////////////////////////////////////////
  93 //                          Dynamic Casts
  94 ////////////////////////////////////////////////////////////////////////////
  95
  96 static pmt_symbol *
  97 _symbol(pmt_t x)
  98 {
  99   return dynamic_cast<pmt_symbol*>(x.get());
 100 }
 101
 102 static pmt_integer *
 103 _integer(pmt_t x)
 104 {
 105   return dynamic_cast<pmt_integer*>(x.get());
 106 }
 107
 108 static pmt_uint64 *
 109 _uint64(pmt_t x)
 110 {
 111   return dynamic_cast<pmt_uint64*>(x.get());
 112 }
 113
 114 static pmt_real *
 115 _real(pmt_t x)
 116 {
 117   return dynamic_cast<pmt_real*>(x.get());
 118 }
 119
 120 static pmt_complex *
 121 _complex(pmt_t x)
 122 {
 123   return dynamic_cast<pmt_complex*>(x.get());
 124 }
 125
 126 static pmt_pair *
 127 _pair(pmt_t x)
 128 {
 129   return dynamic_cast<pmt_pair*>(x.get());
 130 }
 131
 132 static pmt_vector *
 133 _vector(pmt_t x)
 134 {
 135   return dynamic_cast<pmt_vector*>(x.get());
 136 }
 137
 138 static pmt_tuple *
 139 _tuple(pmt_t x)
 140 {
 141   return dynamic_cast<pmt_tuple*>(x.get());
 142 }
 143
 144 static pmt_uniform_vector *
 145 _uniform_vector(pmt_t x)
 146 {
 147   return dynamic_cast<pmt_uniform_vector*>(x.get());
 148 }
 149
 150 static pmt_any *
 151 _any(pmt_t x)
 152 {
 153   return dynamic_cast<pmt_any*>(x.get());
 154 }
 155
 156 ////////////////////////////////////////////////////////////////////////////
 157 //                           Globals
 158 ////////////////////////////////////////////////////////////////////////////
 159
 160 const pmt_t PMT_T = pmt_t(new pmt_bool());              // singleton
 161 const pmt_t PMT_F = pmt_t(new pmt_bool());              // singleton
 162 const pmt_t PMT_NIL = pmt_t(new pmt_null());            // singleton
 163 const pmt_t PMT_EOF = pmt_cons(PMT_NIL, PMT_NIL);       // singleton
 164
 165 ////////////////////////////////////////////////////////////////////////////
 166 //                           Booleans
 167 ////////////////////////////////////////////////////////////////////////////
 168
 169 pmt_bool::pmt_bool(){}
 170
 171 bool
 172 pmt_is_true(pmt_t obj)
 173 {
 174   return obj != PMT_F;
 175 }
 176
 177 bool
 178 pmt_is_false(pmt_t obj)
 179 {
 180   return obj == PMT_F;
 181 }
 182
 183 bool
 184 pmt_is_bool(pmt_t obj)
 185 {
 186   return obj->is_bool();
 187 }
 188
 189 pmt_t
 190 pmt_from_bool(bool val)
 191 {
 192   return val ? PMT_T : PMT_F;
 193 }
 194
 195 bool
 196 pmt_to_bool(pmt_t val)
 197 {
 198   if (val == PMT_T)
 199     return true;
 200   if (val == PMT_F)
 201     return false;
 202   throw pmt_wrong_type("pmt_to_bool", val);
 203 }
 204
 205 ////////////////////////////////////////////////////////////////////////////
 206 //                             Symbols
 207 ////////////////////////////////////////////////////////////////////////////
 208
 209 static const unsigned int SYMBOL_HASH_TABLE_SIZE = 701;
 210 static std::vector<pmt_t> s_symbol_hash_table(SYMBOL_HASH_TABLE_SIZE);
 211
 212 pmt_symbol::pmt_symbol(const std::string &name) : d_name(name){}
 213
 214
 215 static unsigned int
 216 hash_string(const std::string &s)
 217 {
 218   unsigned int h = 0;
 219   unsigned int g = 0;
 220
 221   for (std::string::const_iterator p = s.begin(); p != s.end(); ++p){
 222     h = (h << 4) + (*p & 0xff);
 223     g = h & 0xf0000000;
 224     if (g){
 225       h = h ^ (g >> 24);
 226       h = h ^ g;
 227     }
 228   }
 229   return h;
 230 }
 231
 232 bool
 233 pmt_is_symbol(const pmt_t& obj)
 234 {
 235   return obj->is_symbol();
 236 }
 237
 238 pmt_t
 239 pmt_string_to_symbol(const std::string &name)
 240 {
 241   unsigned hash = hash_string(name) % SYMBOL_HASH_TABLE_SIZE;
 242
 243   // Does a symbol with this name already exist?
 244   for (pmt_t sym = s_symbol_hash_table[hash]; sym; sym = _symbol(sym)->next()){
 245     if (name == _symbol(sym)->name())
 246       return sym;               // Yes.  Return it
 247   }
 248
 249   // Nope.  Make a new one.
 250   pmt_t sym = pmt_t(new pmt_symbol(name));
 251   _symbol(sym)->set_next(s_symbol_hash_table[hash]);
 252   s_symbol_hash_table[hash] = sym;
 253   return sym;
 254 }
 255
 256 // alias...
 257 pmt_t
 258 pmt_intern(const std::string &name)
 259 {
 260   return pmt_string_to_symbol(name);
 261 }
 262
 263 const std::string
 264 pmt_symbol_to_string(const pmt_t& sym)
 265 {
 266   if (!sym->is_symbol())
 267     throw pmt_wrong_type("pmt_symbol_to_string", sym);
 268
 269   return _symbol(sym)->name();
 270 }
 271
 272
 273
 274 ////////////////////////////////////////////////////////////////////////////
 275 //                             Number
 276 ////////////////////////////////////////////////////////////////////////////
 277
 278 bool
 279 pmt_is_number(pmt_t x)
 280 {
 281   return x->is_number();
 282 }
 283
 284 ////////////////////////////////////////////////////////////////////////////
 285 //                             Integer
 286 ////////////////////////////////////////////////////////////////////////////
 287
 288 pmt_integer::pmt_integer(long value) : d_value(value) {}
 289
 290 bool
 291 pmt_is_integer(pmt_t x)
 292 {
 293   return x->is_integer();
 294 }
 295
 296
 297 pmt_t
 298 pmt_from_long(long x)
 299 {
 300   return pmt_t(new pmt_integer(x));
 301 }
 302
 303 long
 304 pmt_to_long(pmt_t x)
 305 {
 306   pmt_integer* i = dynamic_cast<pmt_integer*>(x.get());
 307   if ( i )
 308     return i->value();
 309
 310   throw pmt_wrong_type("pmt_to_long", x);
 311 }
 312
 313 ////////////////////////////////////////////////////////////////////////////
 314 //                             Uint64
 315 ////////////////////////////////////////////////////////////////////////////
 316
 317 pmt_uint64::pmt_uint64(uint64_t value) : d_value(value) {}
 318
 319 bool
 320 pmt_is_uint64(pmt_t x)
 321 {
 322   return x->is_uint64();
 323 }
 324
 325
 326 pmt_t
 327 pmt_from_uint64(uint64_t x)
 328 {
 329   return pmt_t(new pmt_uint64(x));
 330 }
 331
 332 uint64_t
 333 pmt_to_uint64(pmt_t x)
 334 {
 335   if(x->is_uint64())
 336     return _uint64(x)->value();
 337   if(x->is_integer())
 338     {
 339     long tmp = _integer(x)->value();
 340     if(tmp >= 0)
 341         return (uint64_t) tmp;
 342     }
 343
 344   throw pmt_wrong_type("pmt_to_uint64", x);
 345 }
 346
 347 ////////////////////////////////////////////////////////////////////////////
 348 //                              Real
 349 ////////////////////////////////////////////////////////////////////////////
 350
 351 pmt_real::pmt_real(double value) : d_value(value) {}
 352
 353 bool
 354 pmt_is_real(pmt_t x)
 355 {
 356   return x->is_real();
 357 }
 358
 359 pmt_t
 360 pmt_from_double(double x)
 361 {
 362   return pmt_t(new pmt_real(x));
 363 }
 364
 365 double
 366 pmt_to_double(pmt_t x)
 367 {
 368   if (x->is_real())
 369     return _real(x)->value();
 370   if (x->is_integer())
 371     return _integer(x)->value();
 372
 373   throw pmt_wrong_type("pmt_to_double", x);
 374 }
 375
 376 ////////////////////////////////////////////////////////////////////////////
 377 //                              Complex
 378 ////////////////////////////////////////////////////////////////////////////
 379
 380 pmt_complex::pmt_complex(std::complex<double> value) : d_value(value) {}
 381
 382 bool
 383 pmt_is_complex(pmt_t x)
 384 {
 385   return x->is_complex();
 386 }
 387
 388 pmt_t
 389 pmt_make_rectangular(double re, double im)
 390 {
 391   return pmt_t(new pmt_complex(std::complex<double>(re, im)));
 392 }
 393
 394 std::complex<double>
 395 pmt_to_complex(pmt_t x)
 396 {
 397   if (x->is_complex())
 398     return _complex(x)->value();
 399   if (x->is_real())
 400     return _real(x)->value();
 401   if (x->is_integer())
 402     return _integer(x)->value();
 403
 404   throw pmt_wrong_type("pmt_to_complex", x);
 405 }
 406
 407 ////////////////////////////////////////////////////////////////////////////
 408 //                              Pairs
 409 ////////////////////////////////////////////////////////////////////////////
 410
 411 pmt_null::pmt_null() {}
 412 pmt_pair::pmt_pair(const pmt_t& car, const pmt_t& cdr) : d_car(car), d_cdr(cdr) {}
 413
 414 bool
 415 pmt_is_null(const pmt_t& x)
 416 {
 417   return x == PMT_NIL;
 418 }
 419
 420 bool
 421 pmt_is_pair(const pmt_t& obj)
 422 {
 423   return obj->is_pair();
 424 }
 425
 426 pmt_t
 427 pmt_cons(const pmt_t& x, const pmt_t& y)
 428 {
 429   return pmt_t(new pmt_pair(x, y));
 430 }
 431
 432 pmt_t
 433 pmt_car(const pmt_t& pair)
 434 {
 435   pmt_pair* p = dynamic_cast<pmt_pair*>(pair.get());
 436   if ( p )
 437     return p->car();
 438
 439   throw pmt_wrong_type("pmt_car", pair);
 440 }
 441
 442 pmt_t
 443 pmt_cdr(const pmt_t& pair)
 444 {
 445   pmt_pair* p = dynamic_cast<pmt_pair*>(pair.get());
 446   if ( p )
 447     return p->cdr();
 448
 449   throw pmt_wrong_type("pmt_cdr", pair);
 450 }
 451
 452 void
 453 pmt_set_car(pmt_t pair, pmt_t obj)
 454 {
 455   if (pair->is_pair())
 456     _pair(pair)->set_car(obj);
 457   else
 458     throw pmt_wrong_type("pmt_set_car", pair);
 459 }
 460
 461 void
 462 pmt_set_cdr(pmt_t pair, pmt_t obj)
 463 {
 464   if (pair->is_pair())
 465     _pair(pair)->set_cdr(obj);
 466   else
 467     throw pmt_wrong_type("pmt_set_cdr", pair);
 468 }
 469
 470 ////////////////////////////////////////////////////////////////////////////
 471 //                             Vectors
 472 ////////////////////////////////////////////////////////////////////////////
 473
 474 pmt_vector::pmt_vector(size_t len, pmt_t fill)
 475   : d_v(len)
 476 {
 477   for (size_t i = 0; i < len; i++)
 478     d_v[i] = fill;
 479 }
 480
 481 pmt_t
 482 pmt_vector::ref(size_t k) const
 483 {
 484   if (k >= length())
 485     throw pmt_out_of_range("pmt_vector_ref", pmt_from_long(k));
 486   return d_v[k];
 487 }
 488
 489 void
 490 pmt_vector::set(size_t k, pmt_t obj)
 491 {
 492   if (k >= length())
 493     throw pmt_out_of_range("pmt_vector_set", pmt_from_long(k));
 494   d_v[k] = obj;
 495 }
 496
 497 void
 498 pmt_vector::fill(pmt_t obj)
 499 {
 500   for (size_t i = 0; i < length(); i++)
 501     d_v[i] = obj;
 502 }
 503
 504 bool
 505 pmt_is_vector(pmt_t obj)
 506 {
 507   return obj->is_vector();
 508 }
 509
 510 pmt_t
 511 pmt_make_vector(size_t k, pmt_t fill)
 512 {
 513   return pmt_t(new pmt_vector(k, fill));
 514 }
 515
 516 pmt_t
 517 pmt_vector_ref(pmt_t vector, size_t k)
 518 {
 519   if (!vector->is_vector())
 520     throw pmt_wrong_type("pmt_vector_ref", vector);
 521   return _vector(vector)->ref(k);
 522 }
 523
 524 void
 525 pmt_vector_set(pmt_t vector, size_t k, pmt_t obj)
 526 {
 527   if (!vector->is_vector())
 528     throw pmt_wrong_type("pmt_vector_set", vector);
 529   _vector(vector)->set(k, obj);
 530 }
 531
 532 void
 533 pmt_vector_fill(pmt_t vector, pmt_t obj)
 534 {
 535   if (!vector->is_vector())
 536     throw pmt_wrong_type("pmt_vector_set", vector);
 537   _vector(vector)->fill(obj);
 538 }
 539
 540 ////////////////////////////////////////////////////////////////////////////
 541 //                             Tuples
 542 ////////////////////////////////////////////////////////////////////////////
 543
 544 pmt_tuple::pmt_tuple(size_t len)
 545   : d_v(len)
 546 {
 547 }
 548
 549 pmt_t
 550 pmt_tuple::ref(size_t k) const
 551 {
 552   if (k >= length())
 553     throw pmt_out_of_range("pmt_tuple_ref", pmt_from_long(k));
 554   return d_v[k];
 555 }
 556
 557 bool
 558 pmt_is_tuple(pmt_t obj)
 559 {
 560   return obj->is_tuple();
 561 }
 562
 563 pmt_t
 564 pmt_tuple_ref(const pmt_t &tuple, size_t k)
 565 {
 566   if (!tuple->is_tuple())
 567     throw pmt_wrong_type("pmt_tuple_ref", tuple);
 568   return _tuple(tuple)->ref(k);
 569 }
 570
 571 // for (i=0; i < 10; i++)
 572 //   make_constructor()
 573
 574 pmt_t
 575 pmt_make_tuple()
 576 {
 577   return pmt_t(new pmt_tuple(0));
 578 }
 579
 580 pmt_t
 581 pmt_make_tuple(const pmt_t &e0)
 582 {
 583   pmt_tuple *t = new pmt_tuple(1);
 584   t->_set(0, e0);
 585   return pmt_t(t);
 586 }
 587
 588 pmt_t
 589 pmt_make_tuple(const pmt_t &e0, const pmt_t &e1)
 590 {
 591   pmt_tuple *t = new pmt_tuple(2);
 592   t->_set(0, e0);
 593   t->_set(1, e1);
 594   return pmt_t(t);
 595 }
 596
 597 pmt_t
 598 pmt_make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2)
 599 {
 600   pmt_tuple *t = new pmt_tuple(3);
 601   t->_set(0, e0);
 602   t->_set(1, e1);
 603   t->_set(2, e2);
 604   return pmt_t(t);
 605 }
 606
 607 pmt_t
 608 pmt_make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3)
 609 {
 610   pmt_tuple *t = new pmt_tuple(4);
 611   t->_set(0, e0);
 612   t->_set(1, e1);
 613   t->_set(2, e2);
 614   t->_set(3, e3);
 615   return pmt_t(t);
 616 }
 617
 618 pmt_t
 619 pmt_make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4)
 620 {
 621   pmt_tuple *t = new pmt_tuple(5);
 622   t->_set(0, e0);
 623   t->_set(1, e1);
 624   t->_set(2, e2);
 625   t->_set(3, e3);
 626   t->_set(4, e4);
 627   return pmt_t(t);
 628 }
 629
 630 pmt_t
 631 pmt_make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4, const pmt_t &e5)
 632 {
 633   pmt_tuple *t = new pmt_tuple(6);
 634   t->_set(0, e0);
 635   t->_set(1, e1);
 636   t->_set(2, e2);
 637   t->_set(3, e3);
 638   t->_set(4, e4);
 639   t->_set(5, e5);
 640   return pmt_t(t);
 641 }
 642
 643 pmt_t
 644 pmt_make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4, const pmt_t &e5, const pmt_t &e6)
 645 {
 646   pmt_tuple *t = new pmt_tuple(7);
 647   t->_set(0, e0);
 648   t->_set(1, e1);
 649   t->_set(2, e2);
 650   t->_set(3, e3);
 651   t->_set(4, e4);
 652   t->_set(5, e5);
 653   t->_set(6, e6);
 654   return pmt_t(t);
 655 }
 656
 657 pmt_t
 658 pmt_make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4, const pmt_t &e5, const pmt_t &e6, const pmt_t &e7)
 659 {
 660   pmt_tuple *t = new pmt_tuple(8);
 661   t->_set(0, e0);
 662   t->_set(1, e1);
 663   t->_set(2, e2);
 664   t->_set(3, e3);
 665   t->_set(4, e4);
 666   t->_set(5, e5);
 667   t->_set(6, e6);
 668   t->_set(7, e7);
 669   return pmt_t(t);
 670 }
 671
 672 pmt_t
 673 pmt_make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4, const pmt_t &e5, const pmt_t &e6, const pmt_t &e7, const pmt_t &e8)
 674 {
 675   pmt_tuple *t = new pmt_tuple(9);
 676   t->_set(0, e0);
 677   t->_set(1, e1);
 678   t->_set(2, e2);
 679   t->_set(3, e3);
 680   t->_set(4, e4);
 681   t->_set(5, e5);
 682   t->_set(6, e6);
 683   t->_set(7, e7);
 684   t->_set(8, e8);
 685   return pmt_t(t);
 686 }
 687
 688 pmt_t
 689 pmt_make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4, const pmt_t &e5, const pmt_t &e6, const pmt_t &e7, const pmt_t &e8, const pmt_t &e9)
 690 {
 691   pmt_tuple *t = new pmt_tuple(10);
 692   t->_set(0, e0);
 693   t->_set(1, e1);
 694   t->_set(2, e2);
 695   t->_set(3, e3);
 696   t->_set(4, e4);
 697   t->_set(5, e5);
 698   t->_set(6, e6);
 699   t->_set(7, e7);
 700   t->_set(8, e8);
 701   t->_set(9, e9);
 702   return pmt_t(t);
 703 }
 704
 705 pmt_t
 706 pmt_to_tuple(const pmt_t &x)
 707 {
 708   if (x->is_tuple())            // already one
 709     return x;
 710
 711   size_t len = pmt_length(x);
 712   pmt_tuple *t = new pmt_tuple(len);
 713   pmt_t r = pmt_t(t);
 714
 715   if (x->is_vector()){
 716     for (size_t i = 0; i < len; i++)
 717       t->_set(i, _vector(x)->ref(i));
 718     return r;
 719   }
 720
 721   if (x->is_pair()){
 722     pmt_t y = x;
 723     for (size_t i = 0; i < len; i++){
 724       t->_set(i, pmt_car(y));
 725       y = pmt_cdr(y);
 726     }
 727     return r;
 728   }
 729
 730   throw pmt_wrong_type("pmt_to_tuple", x);
 731 }
 732
 733
 734
 735 ////////////////////////////////////////////////////////////////////////////
 736 //                       Uniform Numeric Vectors
 737 ////////////////////////////////////////////////////////////////////////////
 738
 739 bool
 740 pmt_is_uniform_vector(pmt_t x)
 741 {
 742   return x->is_uniform_vector();
 743 }
 744
 745 const void *
 746 pmt_uniform_vector_elements(pmt_t vector, size_t &len)
 747 {
 748   if (!vector->is_uniform_vector())
 749     throw pmt_wrong_type("pmt_uniform_vector_elements", vector);
 750   return _uniform_vector(vector)->uniform_elements(len);
 751 }
 752
 753 void *
 754 pmt_uniform_vector_writable_elements(pmt_t vector, size_t &len)
 755 {
 756   if (!vector->is_uniform_vector())
 757     throw pmt_wrong_type("pmt_uniform_vector_writable_elements", vector);
 758   return _uniform_vector(vector)->uniform_writable_elements(len);
 759 }
 760
 761 ////////////////////////////////////////////////////////////////////////////
 762 //                            Dictionaries
 763 ////////////////////////////////////////////////////////////////////////////
 764
 765 /*
 766  * This is an a-list implementation.
 767  *
 768  * When we need better performance for large dictionaries, consider implementing
 769  * persistent Red-Black trees as described in "Purely Functional Data Structures",
 770  * Chris Okasaki, 1998, section 3.3.
 771  */
 772
 773 bool
 774 pmt_is_dict(const pmt_t &obj)
 775 {
 776   return pmt_is_null(obj) || pmt_is_pair(obj);
 777 }
 778
 779 pmt_t
 780 pmt_make_dict()
 781 {
 782   return PMT_NIL;
 783 }
 784
 785 pmt_t
 786 pmt_dict_add(const pmt_t &dict, const pmt_t &key, const pmt_t &value)
 787 {
 788   if (pmt_is_null(dict))
 789     return pmt_acons(key, value, PMT_NIL);
 790
 791   if (pmt_dict_has_key(dict, key))
 792     return pmt_acons(key, value, pmt_dict_delete(dict, key));
 793
 794   return pmt_acons(key, value, dict);
 795 }
 796
 797 pmt_t
 798 pmt_dict_delete(const pmt_t &dict, const pmt_t &key)
 799 {
 800   if (pmt_is_null(dict))
 801     return dict;
 802
 803   if (pmt_eqv(pmt_caar(dict), key))
 804     return pmt_cdr(dict);
 805
 806   return pmt_cons(pmt_car(dict), pmt_dict_delete(pmt_cdr(dict), key));
 807 }
 808
 809 pmt_t
 810 pmt_dict_ref(const pmt_t &dict, const pmt_t &key, const pmt_t &not_found)
 811 {
 812   pmt_t p = pmt_assv(key, dict);        // look for (key . value) pair
 813   if (pmt_is_pair(p))
 814     return pmt_cdr(p);
 815   else
 816     return not_found;
 817 }
 818
 819 bool
 820 pmt_dict_has_key(const pmt_t &dict, const pmt_t &key)
 821 {
 822   return pmt_is_pair(pmt_assv(key, dict));
 823 }
 824
 825 pmt_t
 826 pmt_dict_items(pmt_t dict)
 827 {
 828   if (!pmt_is_dict(dict))
 829     throw pmt_wrong_type("pmt_dict_values", dict);
 830
 831   return dict;          // equivalent to dict in the a-list case
 832 }
 833
 834 pmt_t
 835 pmt_dict_keys(pmt_t dict)
 836 {
 837   if (!pmt_is_dict(dict))
 838     throw pmt_wrong_type("pmt_dict_keys", dict);
 839
 840   return pmt_map(pmt_car, dict);
 841 }
 842
 843 pmt_t
 844 pmt_dict_values(pmt_t dict)
 845 {
 846   if (!pmt_is_dict(dict))
 847     throw pmt_wrong_type("pmt_dict_keys", dict);
 848
 849   return pmt_map(pmt_cdr, dict);
 850 }
 851
 852 ////////////////////////////////////////////////////////////////////////////
 853 //                                 Any
 854 ////////////////////////////////////////////////////////////////////////////
 855
 856 pmt_any::pmt_any(const boost::any &any) : d_any(any) {}
 857
 858 bool
 859 pmt_is_any(pmt_t obj)
 860 {
 861   return obj->is_any();
 862 }
 863
 864 pmt_t
 865 pmt_make_any(const boost::any &any)
 866 {
 867   return pmt_t(new pmt_any(any));
 868 }
 869
 870 boost::any
 871 pmt_any_ref(pmt_t obj)
 872 {
 873   if (!obj->is_any())
 874     throw pmt_wrong_type("pmt_any_ref", obj);
 875   return _any(obj)->ref();
 876 }
 877
 878 void
 879 pmt_any_set(pmt_t obj, const boost::any &any)
 880 {
 881   if (!obj->is_any())
 882     throw pmt_wrong_type("pmt_any_set", obj);
 883   _any(obj)->set(any);
 884 }
 885
 886 ////////////////////////////////////////////////////////////////////////////
 887 //               msg_accepter -- built from "any"
 888 ////////////////////////////////////////////////////////////////////////////
 889
 890 bool
 891 pmt_is_msg_accepter(const pmt_t &obj)
 892 {
 893   if (!pmt_is_any(obj))
 894     return false;
 895
 896   boost::any r = pmt_any_ref(obj);
 897   return boost::any_cast<gruel::msg_accepter_sptr>(&r) != 0;
 898 }
 899
 900 //! make a msg_accepter
 901 pmt_t
 902 pmt_make_msg_accepter(gruel::msg_accepter_sptr ma)
 903 {
 904   return pmt_make_any(ma);
 905 }
 906
 907 //! Return underlying msg_accepter
 908 gruel::msg_accepter_sptr
 909 pmt_msg_accepter_ref(const pmt_t &obj)
 910 {
 911   try {
 912     return boost::any_cast<gruel::msg_accepter_sptr>(pmt_any_ref(obj));
 913   }
 914   catch (boost::bad_any_cast &e){
 915     throw pmt_wrong_type("pmt_msg_accepter_ref", obj);
 916   }
 917 }
 918
 919
 920 ////////////////////////////////////////////////////////////////////////////
 921 //             Binary Large Object -- currently a u8vector
 922 ////////////////////////////////////////////////////////////////////////////
 923
 924 bool
 925 pmt_is_blob(pmt_t x)
 926 {
 927   // return pmt_is_u8vector(x);
 928   return pmt_is_uniform_vector(x);
 929 }
 930
 931 pmt_t
 932 pmt_make_blob(const void *buf, size_t len_in_bytes)
 933 {
 934   return pmt_init_u8vector(len_in_bytes, (const uint8_t *) buf);
 935 }
 936
 937 const void *
 938 pmt_blob_data(pmt_t blob)
 939 {
 940   size_t len;
 941   return pmt_uniform_vector_elements(blob, len);
 942 }
 943
 944 size_t
 945 pmt_blob_length(pmt_t blob)
 946 {
 947   size_t len;
 948   pmt_uniform_vector_elements(blob, len);
 949   return len;
 950 }
 951
 952
 953 ////////////////////////////////////////////////////////////////////////////
 954 //                          General Functions
 955 ////////////////////////////////////////////////////////////////////////////
 956
 957 bool
 958 pmt_eq(const pmt_t& x, const pmt_t& y)
 959 {
 960   return x == y;
 961 }
 962
 963 bool
 964 pmt_eqv(const pmt_t& x, const pmt_t& y)
 965 {
 966   if (x == y)
 967     return true;
 968
 969   if (x->is_integer() && y->is_integer())
 970     return _integer(x)->value() == _integer(y)->value();
 971
 972   if (x->is_uint64() && y->is_uint64())
 973     return _uint64(x)->value() == _uint64(y)->value();
 974
 975   if (x->is_real() && y->is_real())
 976     return _real(x)->value() == _real(y)->value();
 977
 978   if (x->is_complex() && y->is_complex())
 979     return _complex(x)->value() == _complex(y)->value();
 980
 981   return false;
 982 }
 983
 984 bool
 985 pmt_eqv_raw(pmt_base *x, pmt_base *y)
 986 {
 987   if (x == y)
 988     return true;
 989
 990   if (x->is_integer() && y->is_integer())
 991     return _integer(x)->value() == _integer(y)->value();
 992
 993   if (x->is_uint64() && y->is_uint64())
 994     return _uint64(x)->value() == _uint64(y)->value();
 995
 996   if (x->is_real() && y->is_real())
 997     return _real(x)->value() == _real(y)->value();
 998
 999   if (x->is_complex() && y->is_complex())
1000     return _complex(x)->value() == _complex(y)->value();
1001
1002   return false;
1003 }
1004
1005 bool
1006 pmt_equal(const pmt_t& x, const pmt_t& y)
1007 {
1008   if (pmt_eqv(x, y))
1009     return true;
1010
1011   if (x->is_pair() && y->is_pair())
1012     return pmt_equal(pmt_car(x), pmt_car(y)) && pmt_equal(pmt_cdr(x), pmt_cdr(y));
1013
1014   if (x->is_vector() && y->is_vector()){
1015     pmt_vector *xv = _vector(x);
1016     pmt_vector *yv = _vector(y);
1017     if (xv->length() != yv->length())
1018       return false;
1019
1020     for (unsigned i = 0; i < xv->length(); i++)
1021       if (!pmt_equal(xv->_ref(i), yv->_ref(i)))
1022         return false;
1023
1024     return true;
1025   }
1026
1027   if (x->is_tuple() && y->is_tuple()){
1028     pmt_tuple *xv = _tuple(x);
1029     pmt_tuple *yv = _tuple(y);
1030     if (xv->length() != yv->length())
1031       return false;
1032
1033     for (unsigned i = 0; i < xv->length(); i++)
1034       if (!pmt_equal(xv->_ref(i), yv->_ref(i)))
1035         return false;
1036
1037     return true;
1038   }
1039
1040   if (x->is_uniform_vector() && y->is_uniform_vector()){
1041     pmt_uniform_vector *xv = _uniform_vector(x);
1042     pmt_uniform_vector *yv = _uniform_vector(y);
1043     if (xv->length() != yv->length())
1044       return false;
1045
1046     size_t len_x, len_y;
1047     if (memcmp(xv->uniform_elements(len_x),
1048                yv->uniform_elements(len_y),
1049                len_x) == 0)
1050       return true;
1051
1052     return true;
1053   }
1054
1055   // FIXME add other cases here...
1056
1057   return false;
1058 }
1059
1060 size_t
1061 pmt_length(const pmt_t& x)
1062 {
1063   if (x->is_vector())
1064     return _vector(x)->length();
1065
1066   if (x->is_uniform_vector())
1067     return _uniform_vector(x)->length();
1068
1069   if (x->is_tuple())
1070     return _tuple(x)->length();
1071
1072   if (x->is_null())
1073     return 0;
1074
1075   if (x->is_pair()) {
1076     size_t length=1;
1077     pmt_t it = pmt_cdr(x);
1078     while (pmt_is_pair(it)){
1079       length++;
1080       it = pmt_cdr(it);
1081     }
1082     if (pmt_is_null(it))
1083       return length;
1084
1085     // not a proper list
1086     throw pmt_wrong_type("pmt_length", x);
1087   }
1088
1089   // FIXME dictionary length (number of entries)
1090
1091   throw pmt_wrong_type("pmt_length", x);
1092 }
1093
1094 pmt_t
1095 pmt_assq(pmt_t obj, pmt_t alist)
1096 {
1097   while (pmt_is_pair(alist)){
1098     pmt_t p = pmt_car(alist);
1099     if (!pmt_is_pair(p))        // malformed alist
1100       return PMT_F;
1101
1102     if (pmt_eq(obj, pmt_car(p)))
1103       return p;
1104
1105     alist = pmt_cdr(alist);
1106   }
1107   return PMT_F;
1108 }
1109
1110 /*
1111  * This avoids a bunch of shared_pointer reference count manipulation.
1112  */
1113 pmt_t
1114 pmt_assv_raw(pmt_base *obj, pmt_base *alist)
1115 {
1116   while (alist->is_pair()){
1117     pmt_base *p = ((pmt_pair *)alist)->d_car.get();
1118     if (!p->is_pair())          // malformed alist
1119       return PMT_F;
1120
1121     if (pmt_eqv_raw(obj, ((pmt_pair *)p)->d_car.get()))
1122       return ((pmt_pair *)alist)->d_car;
1123
1124     alist = (((pmt_pair *)alist)->d_cdr).get();
1125   }
1126   return PMT_F;
1127 }
1128
1129 #if 1
1130
1131 pmt_t
1132 pmt_assv(pmt_t obj, pmt_t alist)
1133 {
1134   return pmt_assv_raw(obj.get(), alist.get());
1135 }
1136
1137 #else
1138
1139 pmt_t
1140 pmt_assv(pmt_t obj, pmt_t alist)
1141 {
1142   while (pmt_is_pair(alist)){
1143     pmt_t p = pmt_car(alist);
1144     if (!pmt_is_pair(p))        // malformed alist
1145       return PMT_F;
1146
1147     if (pmt_eqv(obj, pmt_car(p)))
1148       return p;
1149
1150     alist = pmt_cdr(alist);
1151   }
1152   return PMT_F;
1153 }
1154
1155 #endif
1156
1157
1158 pmt_t
1159 pmt_assoc(pmt_t obj, pmt_t alist)
1160 {
1161   while (pmt_is_pair(alist)){
1162     pmt_t p = pmt_car(alist);
1163     if (!pmt_is_pair(p))        // malformed alist
1164       return PMT_F;
1165
1166     if (pmt_equal(obj, pmt_car(p)))
1167       return p;
1168
1169     alist = pmt_cdr(alist);
1170   }
1171   return PMT_F;
1172 }
1173
1174 pmt_t
1175 pmt_map(pmt_t proc(const pmt_t&), pmt_t list)
1176 {
1177   pmt_t r = PMT_NIL;
1178
1179   while(pmt_is_pair(list)){
1180     r = pmt_cons(proc(pmt_car(list)), r);
1181     list = pmt_cdr(list);
1182   }
1183
1184   return pmt_reverse_x(r);
1185 }
1186
1187 pmt_t
1188 pmt_reverse(pmt_t listx)
1189 {
1190   pmt_t list = listx;
1191   pmt_t r = PMT_NIL;
1192
1193   while(pmt_is_pair(list)){
1194     r = pmt_cons(pmt_car(list), r);
1195     list = pmt_cdr(list);
1196   }
1197   if (pmt_is_null(list))
1198     return r;
1199   else
1200     throw pmt_wrong_type("pmt_reverse", listx);
1201 }
1202
1203 pmt_t
1204 pmt_reverse_x(pmt_t list)
1205 {
1206   // FIXME do it destructively
1207   return pmt_reverse(list);
1208 }
1209
1210 pmt_t
1211 pmt_nth(size_t n, pmt_t list)
1212 {
1213   pmt_t t = pmt_nthcdr(n, list);
1214   if (pmt_is_pair(t))
1215     return pmt_car(t);
1216   else
1217     return PMT_NIL;
1218 }
1219
1220 pmt_t
1221 pmt_nthcdr(size_t n, pmt_t list)
1222 {
1223   if (!(pmt_is_pair(list) || pmt_is_null(list)))
1224     throw pmt_wrong_type("pmt_nthcdr", list);
1225
1226   while (n > 0){
1227     if (pmt_is_pair(list)){
1228       list = pmt_cdr(list);
1229       n--;
1230       continue;
1231     }
1232     if (pmt_is_null(list))
1233       return PMT_NIL;
1234     else
1235       throw pmt_wrong_type("pmt_nthcdr: not a LIST", list);
1236   }
1237   return list;
1238 }
1239
1240 pmt_t
1241 pmt_memq(pmt_t obj, pmt_t list)
1242 {
1243   while (pmt_is_pair(list)){
1244     if (pmt_eq(obj, pmt_car(list)))
1245       return list;
1246     list = pmt_cdr(list);
1247   }
1248   return PMT_F;
1249 }
1250
1251 pmt_t
1252 pmt_memv(pmt_t obj, pmt_t list)
1253 {
1254   while (pmt_is_pair(list)){
1255     if (pmt_eqv(obj, pmt_car(list)))
1256       return list;
1257     list = pmt_cdr(list);
1258   }
1259   return PMT_F;
1260 }
1261
1262 pmt_t
1263 pmt_member(pmt_t obj, pmt_t list)
1264 {
1265   while (pmt_is_pair(list)){
1266     if (pmt_equal(obj, pmt_car(list)))
1267       return list;
1268     list = pmt_cdr(list);
1269   }
1270   return PMT_F;
1271 }
1272
1273 bool
1274 pmt_subsetp(pmt_t list1, pmt_t list2)
1275 {
1276   while (pmt_is_pair(list1)){
1277     pmt_t p = pmt_car(list1);
1278     if (pmt_is_false(pmt_memv(p, list2)))
1279       return false;
1280     list1 = pmt_cdr(list1);
1281   }
1282   return true;
1283 }
1284
1285 pmt_t
1286 pmt_list1(const pmt_t& x1)
1287 {
1288   return pmt_cons(x1, PMT_NIL);
1289 }
1290
1291 pmt_t
1292 pmt_list2(const pmt_t& x1, const pmt_t& x2)
1293 {
1294   return pmt_cons(x1, pmt_cons(x2, PMT_NIL));
1295 }
1296
1297 pmt_t
1298 pmt_list3(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3)
1299 {
1300   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, PMT_NIL)));
1301 }
1302
1303 pmt_t
1304 pmt_list4(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3, const pmt_t& x4)
1305 {
1306   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, PMT_NIL))));
1307 }
1308
1309 pmt_t
1310 pmt_list5(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3, const pmt_t& x4, const pmt_t& x5)
1311 {
1312   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, pmt_cons(x5, PMT_NIL)))));
1313 }
1314
1315 pmt_t
1316 pmt_list6(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3, const pmt_t& x4, const pmt_t& x5, const pmt_t& x6)
1317 {
1318   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, pmt_cons(x5, pmt_cons(x6, PMT_NIL))))));
1319 }
1320
1321 pmt_t
1322 pmt_list_add(pmt_t list, const pmt_t& item)
1323 {
1324   return pmt_reverse(pmt_cons(item, pmt_reverse(list)));
1325 }
1326
1327 pmt_t
1328 pmt_caar(pmt_t pair)
1329 {
1330   return (pmt_car(pmt_car(pair)));
1331 }
1332
1333 pmt_t
1334 pmt_cadr(pmt_t pair)
1335 {
1336   return pmt_car(pmt_cdr(pair));
1337 }
1338
1339 pmt_t
1340 pmt_cdar(pmt_t pair)
1341 {
1342   return pmt_cdr(pmt_car(pair));
1343 }
1344
1345 pmt_t
1346 pmt_cddr(pmt_t pair)
1347 {
1348   return pmt_cdr(pmt_cdr(pair));
1349 }
1350
1351 pmt_t
1352 pmt_caddr(pmt_t pair)
1353 {
1354   return pmt_car(pmt_cdr(pmt_cdr(pair)));
1355 }
1356
1357 pmt_t
1358 pmt_cadddr(pmt_t pair)
1359 {
1360   return pmt_car(pmt_cdr(pmt_cdr(pmt_cdr(pair))));
1361 }
1362
1363 bool
1364 pmt_is_eof_object(pmt_t obj)
1365 {
1366   return pmt_eq(obj, PMT_EOF);
1367 }
1368
1369 void
1370 pmt_dump_sizeof()
1371 {
1372   printf("sizeof(pmt_t)              = %3zd\n", sizeof(pmt_t));
1373   printf("sizeof(pmt_base)           = %3zd\n", sizeof(pmt_base));
1374   printf("sizeof(pmt_bool)           = %3zd\n", sizeof(pmt_bool));
1375   printf("sizeof(pmt_symbol)         = %3zd\n", sizeof(pmt_symbol));
1376   printf("sizeof(pmt_integer)        = %3zd\n", sizeof(pmt_integer));
1377   printf("sizeof(pmt_uint64)         = %3zd\n", sizeof(pmt_uint64));
1378   printf("sizeof(pmt_real)           = %3zd\n", sizeof(pmt_real));
1379   printf("sizeof(pmt_complex)        = %3zd\n", sizeof(pmt_complex));
1380   printf("sizeof(pmt_null)           = %3zd\n", sizeof(pmt_null));
1381   printf("sizeof(pmt_pair)           = %3zd\n", sizeof(pmt_pair));
1382   printf("sizeof(pmt_vector)         = %3zd\n", sizeof(pmt_vector));
1383   printf("sizeof(pmt_uniform_vector) = %3zd\n", sizeof(pmt_uniform_vector));
1384 }
1385
1386 } /* namespace pmt */