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