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