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