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 //                          General Functions
 921 ////////////////////////////////////////////////////////////////////////////
 922
 923 bool
 924 pmt_eq(const pmt_t& x, const pmt_t& y)
 925 {
 926   return x == y;
 927 }
 928
 929 bool
 930 pmt_eqv(const pmt_t& x, const pmt_t& y)
 931 {
 932   if (x == y)
 933     return true;
 934
 935   if (x->is_integer() && y->is_integer())
 936     return _integer(x)->value() == _integer(y)->value();
 937
 938   if (x->is_real() && y->is_real())
 939     return _real(x)->value() == _real(y)->value();
 940
 941   if (x->is_complex() && y->is_complex())
 942     return _complex(x)->value() == _complex(y)->value();
 943
 944   return false;
 945 }
 946
 947 bool
 948 pmt_equal(const pmt_t& x, const pmt_t& y)
 949 {
 950   if (pmt_eqv(x, y))
 951     return true;
 952
 953   if (x->is_pair() && y->is_pair())
 954     return pmt_equal(pmt_car(x), pmt_car(y)) && pmt_equal(pmt_cdr(x), pmt_cdr(y));
 955
 956   if (x->is_vector() && y->is_vector()){
 957     pmt_vector *xv = _vector(x);
 958     pmt_vector *yv = _vector(y);
 959     if (xv->length() != yv->length())
 960       return false;
 961
 962     for (unsigned i = 0; i < xv->length(); i++)
 963       if (!pmt_equal(xv->_ref(i), yv->_ref(i)))
 964         return false;
 965
 966     return true;
 967   }
 968
 969   if (x->is_tuple() && y->is_tuple()){
 970     pmt_tuple *xv = _tuple(x);
 971     pmt_tuple *yv = _tuple(y);
 972     if (xv->length() != yv->length())
 973       return false;
 974
 975     for (unsigned i = 0; i < xv->length(); i++)
 976       if (!pmt_equal(xv->_ref(i), yv->_ref(i)))
 977         return false;
 978
 979     return true;
 980   }
 981
 982   if (x->is_uniform_vector() && y->is_uniform_vector()){
 983     pmt_uniform_vector *xv = _uniform_vector(x);
 984     pmt_uniform_vector *yv = _uniform_vector(y);
 985     if (xv->length() != yv->length())
 986       return false;
 987
 988     size_t len_x, len_y;
 989     if (memcmp(xv->uniform_elements(len_x),
 990                yv->uniform_elements(len_y),
 991                len_x) == 0)
 992       return true;
 993
 994     return true;
 995   }
 996
 997   // FIXME add other cases here...
 998
 999   return false;
1000 }
1001
1002 size_t
1003 pmt_length(const pmt_t& x)
1004 {
1005   if (x->is_vector())
1006     return _vector(x)->length();
1007
1008   if (x->is_uniform_vector())
1009     return _uniform_vector(x)->length();
1010
1011   if (x->is_tuple())
1012     return _tuple(x)->length();
1013
1014   if (x->is_null())
1015     return 0;
1016
1017   if (x->is_pair()) {
1018     size_t length=1;
1019     pmt_t it = pmt_cdr(x);
1020     while (pmt_is_pair(it)){
1021       length++;
1022       it = pmt_cdr(it);
1023     }
1024     if (pmt_is_null(it))
1025       return length;
1026
1027     // not a proper list
1028     throw pmt_wrong_type("pmt_length", x);
1029   }
1030
1031   // FIXME dictionary length (number of entries)
1032
1033   throw pmt_wrong_type("pmt_length", x);
1034 }
1035
1036 pmt_t
1037 pmt_assq(pmt_t obj, pmt_t alist)
1038 {
1039   while (pmt_is_pair(alist)){
1040     pmt_t p = pmt_car(alist);
1041     if (!pmt_is_pair(p))        // malformed alist
1042       return PMT_F;
1043
1044     if (pmt_eq(obj, pmt_car(p)))
1045       return p;
1046
1047     alist = pmt_cdr(alist);
1048   }
1049   return PMT_F;
1050 }
1051
1052 pmt_t
1053 pmt_assv(pmt_t obj, pmt_t alist)
1054 {
1055   while (pmt_is_pair(alist)){
1056     pmt_t p = pmt_car(alist);
1057     if (!pmt_is_pair(p))        // malformed alist
1058       return PMT_F;
1059
1060     if (pmt_eqv(obj, pmt_car(p)))
1061       return p;
1062
1063     alist = pmt_cdr(alist);
1064   }
1065   return PMT_F;
1066 }
1067
1068 pmt_t
1069 pmt_assoc(pmt_t obj, pmt_t alist)
1070 {
1071   while (pmt_is_pair(alist)){
1072     pmt_t p = pmt_car(alist);
1073     if (!pmt_is_pair(p))        // malformed alist
1074       return PMT_F;
1075
1076     if (pmt_equal(obj, pmt_car(p)))
1077       return p;
1078
1079     alist = pmt_cdr(alist);
1080   }
1081   return PMT_F;
1082 }
1083
1084 pmt_t
1085 pmt_map(pmt_t proc(const pmt_t&), pmt_t list)
1086 {
1087   pmt_t r = PMT_NIL;
1088
1089   while(pmt_is_pair(list)){
1090     r = pmt_cons(proc(pmt_car(list)), r);
1091     list = pmt_cdr(list);
1092   }
1093
1094   return pmt_reverse_x(r);
1095 }
1096
1097 pmt_t
1098 pmt_reverse(pmt_t listx)
1099 {
1100   pmt_t list = listx;
1101   pmt_t r = PMT_NIL;
1102
1103   while(pmt_is_pair(list)){
1104     r = pmt_cons(pmt_car(list), r);
1105     list = pmt_cdr(list);
1106   }
1107   if (pmt_is_null(list))
1108     return r;
1109   else
1110     throw pmt_wrong_type("pmt_reverse", listx);
1111 }
1112
1113 pmt_t
1114 pmt_reverse_x(pmt_t list)
1115 {
1116   // FIXME do it destructively
1117   return pmt_reverse(list);
1118 }
1119
1120 pmt_t
1121 pmt_nth(size_t n, pmt_t list)
1122 {
1123   pmt_t t = pmt_nthcdr(n, list);
1124   if (pmt_is_pair(t))
1125     return pmt_car(t);
1126   else
1127     return PMT_NIL;
1128 }
1129
1130 pmt_t
1131 pmt_nthcdr(size_t n, pmt_t list)
1132 {
1133   if (!(pmt_is_pair(list) || pmt_is_null(list)))
1134     throw pmt_wrong_type("pmt_nthcdr", list);
1135
1136   while (n > 0){
1137     if (pmt_is_pair(list)){
1138       list = pmt_cdr(list);
1139       n--;
1140       continue;
1141     }
1142     if (pmt_is_null(list))
1143       return PMT_NIL;
1144     else
1145       throw pmt_wrong_type("pmt_nthcdr: not a LIST", list);
1146   }
1147   return list;
1148 }
1149
1150 pmt_t
1151 pmt_memq(pmt_t obj, pmt_t list)
1152 {
1153   while (pmt_is_pair(list)){
1154     if (pmt_eq(obj, pmt_car(list)))
1155       return list;
1156     list = pmt_cdr(list);
1157   }
1158   return PMT_F;
1159 }
1160
1161 pmt_t
1162 pmt_memv(pmt_t obj, pmt_t list)
1163 {
1164   while (pmt_is_pair(list)){
1165     if (pmt_eqv(obj, pmt_car(list)))
1166       return list;
1167     list = pmt_cdr(list);
1168   }
1169   return PMT_F;
1170 }
1171
1172 pmt_t
1173 pmt_member(pmt_t obj, pmt_t list)
1174 {
1175   while (pmt_is_pair(list)){
1176     if (pmt_equal(obj, pmt_car(list)))
1177       return list;
1178     list = pmt_cdr(list);
1179   }
1180   return PMT_F;
1181 }
1182
1183 bool
1184 pmt_subsetp(pmt_t list1, pmt_t list2)
1185 {
1186   while (pmt_is_pair(list1)){
1187     pmt_t p = pmt_car(list1);
1188     if (pmt_is_false(pmt_memv(p, list2)))
1189       return false;
1190     list1 = pmt_cdr(list1);
1191   }
1192   return true;
1193 }
1194
1195 pmt_t
1196 pmt_list1(const pmt_t& x1)
1197 {
1198   return pmt_cons(x1, PMT_NIL);
1199 }
1200
1201 pmt_t
1202 pmt_list2(const pmt_t& x1, const pmt_t& x2)
1203 {
1204   return pmt_cons(x1, pmt_cons(x2, PMT_NIL));
1205 }
1206
1207 pmt_t
1208 pmt_list3(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3)
1209 {
1210   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, PMT_NIL)));
1211 }
1212
1213 pmt_t
1214 pmt_list4(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3, const pmt_t& x4)
1215 {
1216   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, PMT_NIL))));
1217 }
1218
1219 pmt_t
1220 pmt_list5(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3, const pmt_t& x4, const pmt_t& x5)
1221 {
1222   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, pmt_cons(x5, PMT_NIL)))));
1223 }
1224
1225 pmt_t
1226 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)
1227 {
1228   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, pmt_cons(x5, pmt_cons(x6, PMT_NIL))))));
1229 }
1230
1231 pmt_t
1232 pmt_list_add(pmt_t list, const pmt_t& item)
1233 {
1234   return pmt_reverse(pmt_cons(item, pmt_reverse(list)));
1235 }
1236
1237 pmt_t
1238 pmt_caar(pmt_t pair)
1239 {
1240   return (pmt_car(pmt_car(pair)));
1241 }
1242
1243 pmt_t
1244 pmt_cadr(pmt_t pair)
1245 {
1246   return pmt_car(pmt_cdr(pair));
1247 }
1248
1249 pmt_t
1250 pmt_cdar(pmt_t pair)
1251 {
1252   return pmt_cdr(pmt_car(pair));
1253 }
1254
1255 pmt_t
1256 pmt_cddr(pmt_t pair)
1257 {
1258   return pmt_cdr(pmt_cdr(pair));
1259 }
1260
1261 pmt_t
1262 pmt_caddr(pmt_t pair)
1263 {
1264   return pmt_car(pmt_cdr(pmt_cdr(pair)));
1265 }
1266
1267 pmt_t
1268 pmt_cadddr(pmt_t pair)
1269 {
1270   return pmt_car(pmt_cdr(pmt_cdr(pmt_cdr(pair))));
1271 }
1272
1273 bool
1274 pmt_is_eof_object(pmt_t obj)
1275 {
1276   return pmt_eq(obj, PMT_EOF);
1277 }
1278
1279 void
1280 pmt_dump_sizeof()
1281 {
1282   printf("sizeof(pmt_t)              = %3zd\n", sizeof(pmt_t));
1283   printf("sizeof(pmt_base)           = %3zd\n", sizeof(pmt_base));
1284   printf("sizeof(pmt_bool)           = %3zd\n", sizeof(pmt_bool));
1285   printf("sizeof(pmt_symbol)         = %3zd\n", sizeof(pmt_symbol));
1286   printf("sizeof(pmt_integer)        = %3zd\n", sizeof(pmt_integer));
1287   printf("sizeof(pmt_real)           = %3zd\n", sizeof(pmt_real));
1288   printf("sizeof(pmt_complex)        = %3zd\n", sizeof(pmt_complex));
1289   printf("sizeof(pmt_null)           = %3zd\n", sizeof(pmt_null));
1290   printf("sizeof(pmt_pair)           = %3zd\n", sizeof(pmt_pair));
1291   printf("sizeof(pmt_vector)         = %3zd\n", sizeof(pmt_vector));
1292   printf("sizeof(pmt_dict)           = %3zd\n", sizeof(pmt_dict));
1293   printf("sizeof(pmt_uniform_vector) = %3zd\n", sizeof(pmt_uniform_vector));
1294 }
1295
1296 } /* namespace pmt */