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
 677   if (x->is_vector()){
 678     for (size_t i = 0; i < len; i++)
 679       t->_set(i, _vector(x)->ref(i));
 680     return pmt_t(t);
 681   }
 682
 683   if (x->is_pair()){
 684     pmt_t y = x;
 685     for (size_t i = 0; i < len; i++){
 686       t->_set(i, pmt_car(y));
 687       y = pmt_cdr(x);
 688     }
 689     return pmt_t(t);
 690   }
 691
 692   throw pmt_wrong_type("pmt_to_tuple", x);
 693 }
 694
 695
 696
 697 ////////////////////////////////////////////////////////////////////////////
 698 //                       Uniform Numeric Vectors
 699 ////////////////////////////////////////////////////////////////////////////
 700
 701 bool
 702 pmt_is_uniform_vector(pmt_t x)
 703 {
 704   return x->is_uniform_vector();
 705 }
 706
 707 const void *
 708 pmt_uniform_vector_elements(pmt_t vector, size_t &len)
 709 {
 710   if (!vector->is_uniform_vector())
 711     throw pmt_wrong_type("pmt_uniform_vector_elements", vector);
 712   return _uniform_vector(vector)->uniform_elements(len);
 713 }
 714
 715 void *
 716 pmt_uniform_vector_writable_elements(pmt_t vector, size_t &len)
 717 {
 718   if (!vector->is_uniform_vector())
 719     throw pmt_wrong_type("pmt_uniform_vector_writable_elements", vector);
 720   return _uniform_vector(vector)->uniform_writable_elements(len);
 721 }
 722
 723 ////////////////////////////////////////////////////////////////////////////
 724 //                            Dictionaries
 725 ////////////////////////////////////////////////////////////////////////////
 726
 727 pmt_dict::pmt_dict()
 728   : d_alist(PMT_NIL)
 729 {
 730 }
 731
 732 void
 733 pmt_dict::set(pmt_t key, pmt_t value)
 734 {
 735   pmt_t p = pmt_assv(key, d_alist);     // look for (key . value) pair
 736   if (pmt_is_pair(p)){                  // found existing pair...
 737     pmt_set_cdr(p, value);              // overrwrite cdr with new value
 738   }
 739   else {                                // not in the dict
 740     d_alist = pmt_cons(pmt_cons(key, value), d_alist);  // add new (key . value) pair
 741   }
 742 }
 743
 744 pmt_t
 745 pmt_dict::ref(pmt_t key, pmt_t not_found) const
 746 {
 747   pmt_t p = pmt_assv(key, d_alist);     // look for (key . value) pair
 748   if (pmt_is_pair(p))
 749     return pmt_cdr(p);
 750   else
 751     return not_found;
 752 }
 753
 754 bool
 755 pmt_dict::has_key(pmt_t key) const
 756 {
 757   return pmt_is_pair(pmt_assv(key, d_alist));
 758 }
 759
 760 pmt_t
 761 pmt_dict::items() const
 762 {
 763   return d_alist;
 764 }
 765
 766 pmt_t
 767 pmt_dict::keys() const
 768 {
 769   return pmt_map(pmt_car, d_alist);
 770 }
 771
 772 pmt_t
 773 pmt_dict::values() const
 774 {
 775   return pmt_map(pmt_cdr, d_alist);
 776 }
 777
 778 bool
 779 pmt_is_dict(pmt_t obj)
 780 {
 781   return obj->is_dict();
 782 }
 783
 784 pmt_t
 785 pmt_make_dict()
 786 {
 787   return pmt_t(new pmt_dict());
 788 }
 789
 790 void
 791 pmt_dict_set(pmt_t dict, pmt_t key, pmt_t value)
 792 {
 793   pmt_dict* d = _dict(dict);
 794   if (!d)
 795     throw pmt_wrong_type("pmt_dict_set", dict);
 796
 797   d->set(key, value);
 798 }
 799
 800 bool
 801 pmt_dict_has_key(pmt_t dict, pmt_t key)
 802 {
 803   pmt_dict* d = _dict(dict);
 804   if (!d)
 805     throw pmt_wrong_type("pmt_dict_has_key", dict);
 806
 807   return d->has_key(key);
 808 }
 809
 810 pmt_t
 811 pmt_dict_ref(pmt_t dict, pmt_t key, pmt_t not_found)
 812 {
 813   pmt_dict* d = _dict(dict);
 814   if (!d)
 815     throw pmt_wrong_type("pmt_dict_ref", dict);
 816
 817   return d->ref(key, not_found);
 818 }
 819
 820 pmt_t
 821 pmt_dict_items(pmt_t dict)
 822 {
 823   if (!dict->is_dict())
 824     throw pmt_wrong_type("pmt_dict_items", dict);
 825
 826   return _dict(dict)->items();
 827 }
 828
 829 pmt_t
 830 pmt_dict_keys(pmt_t dict)
 831 {
 832   if (!dict->is_dict())
 833     throw pmt_wrong_type("pmt_dict_keys", dict);
 834
 835   return _dict(dict)->keys();
 836 }
 837
 838 pmt_t
 839 pmt_dict_values(pmt_t dict)
 840 {
 841   if (!dict->is_dict())
 842     throw pmt_wrong_type("pmt_dict_values", dict);
 843
 844   return _dict(dict)->values();
 845 }
 846
 847 ////////////////////////////////////////////////////////////////////////////
 848 //                                 Any
 849 ////////////////////////////////////////////////////////////////////////////
 850
 851 pmt_any::pmt_any(const boost::any &any) : d_any(any) {}
 852
 853 bool
 854 pmt_is_any(pmt_t obj)
 855 {
 856   return obj->is_any();
 857 }
 858
 859 pmt_t
 860 pmt_make_any(const boost::any &any)
 861 {
 862   return pmt_t(new pmt_any(any));
 863 }
 864
 865 boost::any
 866 pmt_any_ref(pmt_t obj)
 867 {
 868   if (!obj->is_any())
 869     throw pmt_wrong_type("pmt_any_ref", obj);
 870   return _any(obj)->ref();
 871 }
 872
 873 void
 874 pmt_any_set(pmt_t obj, const boost::any &any)
 875 {
 876   if (!obj->is_any())
 877     throw pmt_wrong_type("pmt_any_set", obj);
 878   _any(obj)->set(any);
 879 }
 880
 881 ////////////////////////////////////////////////////////////////////////////
 882 //                          General Functions
 883 ////////////////////////////////////////////////////////////////////////////
 884
 885 bool
 886 pmt_eq(const pmt_t& x, const pmt_t& y)
 887 {
 888   return x == y;
 889 }
 890
 891 bool
 892 pmt_eqv(const pmt_t& x, const pmt_t& y)
 893 {
 894   if (x == y)
 895     return true;
 896
 897   if (x->is_integer() && y->is_integer())
 898     return _integer(x)->value() == _integer(y)->value();
 899
 900   if (x->is_real() && y->is_real())
 901     return _real(x)->value() == _real(y)->value();
 902
 903   if (x->is_complex() && y->is_complex())
 904     return _complex(x)->value() == _complex(y)->value();
 905
 906   return false;
 907 }
 908
 909 bool
 910 pmt_equal(const pmt_t& x, const pmt_t& y)
 911 {
 912   if (pmt_eqv(x, y))
 913     return true;
 914
 915   if (x->is_pair() && y->is_pair())
 916     return pmt_equal(pmt_car(x), pmt_car(y)) && pmt_equal(pmt_cdr(x), pmt_cdr(y));
 917
 918   if (x->is_vector() && y->is_vector()){
 919     pmt_vector *xv = _vector(x);
 920     pmt_vector *yv = _vector(y);
 921     if (xv->length() != yv->length())
 922       return false;
 923
 924     for (unsigned i = 0; i < xv->length(); i++)
 925       if (!pmt_equal(xv->_ref(i), yv->_ref(i)))
 926         return false;
 927
 928     return true;
 929   }
 930
 931   if (x->is_uniform_vector() && y->is_uniform_vector()){
 932     pmt_uniform_vector *xv = _uniform_vector(x);
 933     pmt_uniform_vector *yv = _uniform_vector(y);
 934     if (xv->length() != yv->length())
 935       return false;
 936
 937     size_t len_x, len_y;
 938     if (memcmp(xv->uniform_elements(len_x),
 939                yv->uniform_elements(len_y),
 940                len_x) == 0)
 941       return true;
 942
 943     return true;
 944   }
 945
 946   // FIXME add other cases here...
 947
 948   return false;
 949 }
 950
 951 size_t
 952 pmt_length(const pmt_t& x)
 953 {
 954   if (x->is_vector())
 955     return _vector(x)->length();
 956
 957   if (x->is_uniform_vector())
 958     return _uniform_vector(x)->length();
 959
 960   if (x->is_tuple())
 961     return _tuple(x)->length();
 962
 963   if (x->is_null())
 964     return 0;
 965
 966   if (x->is_pair()) {
 967     size_t length=1;
 968     pmt_t it = pmt_cdr(x);
 969     while (pmt_is_pair(it)){
 970       length++;
 971       it = pmt_cdr(it);
 972     }
 973     if (pmt_is_null(it))
 974       return length;
 975
 976     // not a proper list
 977     throw pmt_wrong_type("pmt_length", x);
 978   }
 979
 980   // FIXME dictionary length (number of entries)
 981
 982   throw pmt_wrong_type("pmt_length", x);
 983 }
 984
 985 pmt_t
 986 pmt_assq(pmt_t obj, pmt_t alist)
 987 {
 988   while (pmt_is_pair(alist)){
 989     pmt_t p = pmt_car(alist);
 990     if (!pmt_is_pair(p))        // malformed alist
 991       return PMT_F;
 992
 993     if (pmt_eq(obj, pmt_car(p)))
 994       return p;
 995
 996     alist = pmt_cdr(alist);
 997   }
 998   return PMT_F;
 999 }
1000
1001 pmt_t
1002 pmt_assv(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_eqv(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_assoc(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_equal(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_map(pmt_t proc(const pmt_t&), pmt_t list)
1035 {
1036   pmt_t r = PMT_NIL;
1037
1038   while(pmt_is_pair(list)){
1039     r = pmt_cons(proc(pmt_car(list)), r);
1040     list = pmt_cdr(list);
1041   }
1042
1043   return pmt_reverse_x(r);
1044 }
1045
1046 pmt_t
1047 pmt_reverse(pmt_t listx)
1048 {
1049   pmt_t list = listx;
1050   pmt_t r = PMT_NIL;
1051
1052   while(pmt_is_pair(list)){
1053     r = pmt_cons(pmt_car(list), r);
1054     list = pmt_cdr(list);
1055   }
1056   if (pmt_is_null(list))
1057     return r;
1058   else
1059     throw pmt_wrong_type("pmt_reverse", listx);
1060 }
1061
1062 pmt_t
1063 pmt_reverse_x(pmt_t list)
1064 {
1065   // FIXME do it destructively
1066   return pmt_reverse(list);
1067 }
1068
1069 pmt_t
1070 pmt_nth(size_t n, pmt_t list)
1071 {
1072   pmt_t t = pmt_nthcdr(n, list);
1073   if (pmt_is_pair(t))
1074     return pmt_car(t);
1075   else
1076     return PMT_NIL;
1077 }
1078
1079 pmt_t
1080 pmt_nthcdr(size_t n, pmt_t list)
1081 {
1082   if (!(pmt_is_pair(list) || pmt_is_null(list)))
1083     throw pmt_wrong_type("pmt_nthcdr", list);
1084
1085   while (n > 0){
1086     if (pmt_is_pair(list)){
1087       list = pmt_cdr(list);
1088       n--;
1089       continue;
1090     }
1091     if (pmt_is_null(list))
1092       return PMT_NIL;
1093     else
1094       throw pmt_wrong_type("pmt_nthcdr: not a LIST", list);
1095   }
1096   return list;
1097 }
1098
1099 pmt_t
1100 pmt_memq(pmt_t obj, pmt_t list)
1101 {
1102   while (pmt_is_pair(list)){
1103     if (pmt_eq(obj, pmt_car(list)))
1104       return list;
1105     list = pmt_cdr(list);
1106   }
1107   return PMT_F;
1108 }
1109
1110 pmt_t
1111 pmt_memv(pmt_t obj, pmt_t list)
1112 {
1113   while (pmt_is_pair(list)){
1114     if (pmt_eqv(obj, pmt_car(list)))
1115       return list;
1116     list = pmt_cdr(list);
1117   }
1118   return PMT_F;
1119 }
1120
1121 pmt_t
1122 pmt_member(pmt_t obj, pmt_t list)
1123 {
1124   while (pmt_is_pair(list)){
1125     if (pmt_equal(obj, pmt_car(list)))
1126       return list;
1127     list = pmt_cdr(list);
1128   }
1129   return PMT_F;
1130 }
1131
1132 bool
1133 pmt_subsetp(pmt_t list1, pmt_t list2)
1134 {
1135   while (pmt_is_pair(list1)){
1136     pmt_t p = pmt_car(list1);
1137     if (pmt_is_false(pmt_memv(p, list2)))
1138       return false;
1139     list1 = pmt_cdr(list1);
1140   }
1141   return true;
1142 }
1143
1144 pmt_t
1145 pmt_list1(const pmt_t& x1)
1146 {
1147   return pmt_cons(x1, PMT_NIL);
1148 }
1149
1150 pmt_t
1151 pmt_list2(const pmt_t& x1, const pmt_t& x2)
1152 {
1153   return pmt_cons(x1, pmt_cons(x2, PMT_NIL));
1154 }
1155
1156 pmt_t
1157 pmt_list3(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3)
1158 {
1159   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, PMT_NIL)));
1160 }
1161
1162 pmt_t
1163 pmt_list4(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3, const pmt_t& x4)
1164 {
1165   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, PMT_NIL))));
1166 }
1167
1168 pmt_t
1169 pmt_list5(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3, const pmt_t& x4, const pmt_t& x5)
1170 {
1171   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, pmt_cons(x5, PMT_NIL)))));
1172 }
1173
1174 pmt_t
1175 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)
1176 {
1177   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, pmt_cons(x5, pmt_cons(x6, PMT_NIL))))));
1178 }
1179
1180 pmt_t
1181 pmt_list_add(pmt_t list, const pmt_t& item)
1182 {
1183   return pmt_reverse(pmt_cons(item, pmt_reverse(list)));
1184 }
1185
1186 pmt_t
1187 pmt_caar(pmt_t pair)
1188 {
1189   return (pmt_car(pmt_car(pair)));
1190 }
1191
1192 pmt_t
1193 pmt_cadr(pmt_t pair)
1194 {
1195   return pmt_car(pmt_cdr(pair));
1196 }
1197
1198 pmt_t
1199 pmt_cdar(pmt_t pair)
1200 {
1201   return pmt_cdr(pmt_car(pair));
1202 }
1203
1204 pmt_t
1205 pmt_cddr(pmt_t pair)
1206 {
1207   return pmt_cdr(pmt_cdr(pair));
1208 }
1209
1210 pmt_t
1211 pmt_caddr(pmt_t pair)
1212 {
1213   return pmt_car(pmt_cdr(pmt_cdr(pair)));
1214 }
1215
1216 pmt_t
1217 pmt_cadddr(pmt_t pair)
1218 {
1219   return pmt_car(pmt_cdr(pmt_cdr(pmt_cdr(pair))));
1220 }
1221
1222 bool
1223 pmt_is_eof_object(pmt_t obj)
1224 {
1225   return pmt_eq(obj, PMT_EOF);
1226 }
1227
1228 void
1229 pmt_dump_sizeof()
1230 {
1231   printf("sizeof(pmt_t)              = %3zd\n", sizeof(pmt_t));
1232   printf("sizeof(pmt_base)           = %3zd\n", sizeof(pmt_base));
1233   printf("sizeof(pmt_bool)           = %3zd\n", sizeof(pmt_bool));
1234   printf("sizeof(pmt_symbol)         = %3zd\n", sizeof(pmt_symbol));
1235   printf("sizeof(pmt_integer)        = %3zd\n", sizeof(pmt_integer));
1236   printf("sizeof(pmt_real)           = %3zd\n", sizeof(pmt_real));
1237   printf("sizeof(pmt_complex)        = %3zd\n", sizeof(pmt_complex));
1238   printf("sizeof(pmt_null)           = %3zd\n", sizeof(pmt_null));
1239   printf("sizeof(pmt_pair)           = %3zd\n", sizeof(pmt_pair));
1240   printf("sizeof(pmt_vector)         = %3zd\n", sizeof(pmt_vector));
1241   printf("sizeof(pmt_dict)           = %3zd\n", sizeof(pmt_dict));
1242   printf("sizeof(pmt_uniform_vector) = %3zd\n", sizeof(pmt_uniform_vector));
1243 }
1244
1245 } /* namespace pmt */