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

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