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