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_uniform_vector *
 130 _uniform_vector(pmt_t x)
 131 {
 132   return dynamic_cast<pmt_uniform_vector*>(x.get());
 133 }
 134
 135 static pmt_dict *
 136 _dict(pmt_t x)
 137 {
 138   return dynamic_cast<pmt_dict*>(x.get());
 139 }
 140
 141 static pmt_any *
 142 _any(pmt_t x)
 143 {
 144   return dynamic_cast<pmt_any*>(x.get());
 145 }
 146
 147 ////////////////////////////////////////////////////////////////////////////
 148 //                           Globals
 149 ////////////////////////////////////////////////////////////////////////////
 150
 151 const pmt_t PMT_T = pmt_t(new pmt_bool());              // singleton
 152 const pmt_t PMT_F = pmt_t(new pmt_bool());              // singleton
 153 const pmt_t PMT_NIL = pmt_t(new pmt_null());            // singleton
 154 const pmt_t PMT_EOF = pmt_cons(PMT_NIL, PMT_NIL);       // singleton
 155
 156 ////////////////////////////////////////////////////////////////////////////
 157 //                           Booleans
 158 ////////////////////////////////////////////////////////////////////////////
 159
 160 pmt_bool::pmt_bool(){}
 161
 162 bool
 163 pmt_is_true(pmt_t obj)
 164 {
 165   return obj != PMT_F;
 166 }
 167
 168 bool
 169 pmt_is_false(pmt_t obj)
 170 {
 171   return obj == PMT_F;
 172 }
 173
 174 bool
 175 pmt_is_bool(pmt_t obj)
 176 {
 177   return obj->is_bool();
 178 }
 179
 180 pmt_t
 181 pmt_from_bool(bool val)
 182 {
 183   return val ? PMT_T : PMT_F;
 184 }
 185
 186 bool
 187 pmt_to_bool(pmt_t val)
 188 {
 189   if (val == PMT_T)
 190     return true;
 191   if (val == PMT_F)
 192     return false;
 193   throw pmt_wrong_type("pmt_to_bool", val);
 194 }
 195
 196 ////////////////////////////////////////////////////////////////////////////
 197 //                             Symbols
 198 ////////////////////////////////////////////////////////////////////////////
 199
 200 static const unsigned int SYMBOL_HASH_TABLE_SIZE = 701;
 201 static std::vector<pmt_t> s_symbol_hash_table(SYMBOL_HASH_TABLE_SIZE);
 202
 203 pmt_symbol::pmt_symbol(const std::string &name) : d_name(name){}
 204
 205
 206 static unsigned int
 207 hash_string(const std::string &s)
 208 {
 209   unsigned int h = 0;
 210   unsigned int g = 0;
 211
 212   for (std::string::const_iterator p = s.begin(); p != s.end(); ++p){
 213     h = (h << 4) + (*p & 0xff);
 214     g = h & 0xf0000000;
 215     if (g){
 216       h = h ^ (g >> 24);
 217       h = h ^ g;
 218     }
 219   }
 220   return h;
 221 }
 222
 223 bool
 224 pmt_is_symbol(const pmt_t& obj)
 225 {
 226   return obj->is_symbol();
 227 }
 228
 229 pmt_t
 230 pmt_string_to_symbol(const std::string &name)
 231 {
 232   unsigned hash = hash_string(name) % SYMBOL_HASH_TABLE_SIZE;
 233
 234   // Does a symbol with this name already exist?
 235   for (pmt_t sym = s_symbol_hash_table[hash]; sym; sym = _symbol(sym)->next()){
 236     if (name == _symbol(sym)->name())
 237       return sym;               // Yes.  Return it
 238   }
 239
 240   // Nope.  Make a new one.
 241   pmt_t sym = pmt_t(new pmt_symbol(name));
 242   _symbol(sym)->set_next(s_symbol_hash_table[hash]);
 243   s_symbol_hash_table[hash] = sym;
 244   return sym;
 245 }
 246
 247 // alias...
 248 pmt_t
 249 pmt_intern(const std::string &name)
 250 {
 251   return pmt_string_to_symbol(name);
 252 }
 253
 254 const std::string
 255 pmt_symbol_to_string(const pmt_t& sym)
 256 {
 257   if (!sym->is_symbol())
 258     throw pmt_wrong_type("pmt_symbol_to_string", sym);
 259
 260   return _symbol(sym)->name();
 261 }
 262
 263
 264
 265 ////////////////////////////////////////////////////////////////////////////
 266 //                             Number
 267 ////////////////////////////////////////////////////////////////////////////
 268
 269 bool
 270 pmt_is_number(pmt_t x)
 271 {
 272   return x->is_number();
 273 }
 274
 275 ////////////////////////////////////////////////////////////////////////////
 276 //                             Integer
 277 ////////////////////////////////////////////////////////////////////////////
 278
 279 pmt_integer::pmt_integer(long value) : d_value(value) {}
 280
 281 bool
 282 pmt_is_integer(pmt_t x)
 283 {
 284   return x->is_integer();
 285 }
 286
 287
 288 pmt_t
 289 pmt_from_long(long x)
 290 {
 291   return pmt_t(new pmt_integer(x));
 292 }
 293
 294 long
 295 pmt_to_long(pmt_t x)
 296 {
 297   pmt_integer* i = dynamic_cast<pmt_integer*>(x.get());
 298   if ( i )
 299     return i->value();
 300
 301   throw pmt_wrong_type("pmt_to_long", x);
 302 }
 303
 304 ////////////////////////////////////////////////////////////////////////////
 305 //                              Real
 306 ////////////////////////////////////////////////////////////////////////////
 307
 308 pmt_real::pmt_real(double value) : d_value(value) {}
 309
 310 bool
 311 pmt_is_real(pmt_t x)
 312 {
 313   return x->is_real();
 314 }
 315
 316 pmt_t
 317 pmt_from_double(double x)
 318 {
 319   return pmt_t(new pmt_real(x));
 320 }
 321
 322 double
 323 pmt_to_double(pmt_t x)
 324 {
 325   if (x->is_real())
 326     return _real(x)->value();
 327   if (x->is_integer())
 328     return _integer(x)->value();
 329
 330   throw pmt_wrong_type("pmt_to_double", x);
 331 }
 332
 333 ////////////////////////////////////////////////////////////////////////////
 334 //                              Complex
 335 ////////////////////////////////////////////////////////////////////////////
 336
 337 pmt_complex::pmt_complex(std::complex<double> value) : d_value(value) {}
 338
 339 bool
 340 pmt_is_complex(pmt_t x)
 341 {
 342   return x->is_complex();
 343 }
 344
 345 pmt_t
 346 pmt_make_rectangular(double re, double im)
 347 {
 348   return pmt_t(new pmt_complex(std::complex<double>(re, im)));
 349 }
 350
 351 std::complex<double>
 352 pmt_to_complex(pmt_t x)
 353 {
 354   if (x->is_complex())
 355     return _complex(x)->value();
 356   if (x->is_real())
 357     return _real(x)->value();
 358   if (x->is_integer())
 359     return _integer(x)->value();
 360
 361   throw pmt_wrong_type("pmt_to_complex", x);
 362 }
 363
 364 ////////////////////////////////////////////////////////////////////////////
 365 //                              Pairs
 366 ////////////////////////////////////////////////////////////////////////////
 367
 368 pmt_null::pmt_null() {}
 369 pmt_pair::pmt_pair(const pmt_t& car, const pmt_t& cdr) : d_car(car), d_cdr(cdr) {}
 370
 371 bool
 372 pmt_is_null(const pmt_t& x)
 373 {
 374   return x == PMT_NIL;
 375 }
 376
 377 bool
 378 pmt_is_pair(const pmt_t& obj)
 379 {
 380   return obj->is_pair();
 381 }
 382
 383 pmt_t
 384 pmt_cons(const pmt_t& x, const pmt_t& y)
 385 {
 386   return pmt_t(new pmt_pair(x, y));
 387 }
 388
 389 pmt_t
 390 pmt_car(const pmt_t& pair)
 391 {
 392   pmt_pair* p = dynamic_cast<pmt_pair*>(pair.get());
 393   if ( p )
 394     return p->car();
 395
 396   throw pmt_wrong_type("pmt_car", pair);
 397 }
 398
 399 pmt_t
 400 pmt_cdr(const pmt_t& pair)
 401 {
 402   pmt_pair* p = dynamic_cast<pmt_pair*>(pair.get());
 403   if ( p )
 404     return p->cdr();
 405
 406   throw pmt_wrong_type("pmt_cdr", pair);
 407 }
 408
 409 void
 410 pmt_set_car(pmt_t pair, pmt_t obj)
 411 {
 412   if (pair->is_pair())
 413     _pair(pair)->set_car(obj);
 414   else
 415     throw pmt_wrong_type("pmt_set_car", pair);
 416 }
 417
 418 void
 419 pmt_set_cdr(pmt_t pair, pmt_t obj)
 420 {
 421   if (pair->is_pair())
 422     _pair(pair)->set_cdr(obj);
 423   else
 424     throw pmt_wrong_type("pmt_set_cdr", pair);
 425 }
 426
 427 ////////////////////////////////////////////////////////////////////////////
 428 //                             Vectors
 429 ////////////////////////////////////////////////////////////////////////////
 430
 431 pmt_vector::pmt_vector(size_t len, pmt_t fill)
 432   : d_v(len)
 433 {
 434   for (size_t i = 0; i < len; i++)
 435     d_v[i] = fill;
 436 }
 437
 438 pmt_t
 439 pmt_vector::ref(size_t k) const
 440 {
 441   if (k >= length())
 442     throw pmt_out_of_range("pmt_vector_ref", pmt_from_long(k));
 443   return d_v[k];
 444 }
 445
 446 void
 447 pmt_vector::set(size_t k, pmt_t obj)
 448 {
 449   if (k >= length())
 450     throw pmt_out_of_range("pmt_vector_set", pmt_from_long(k));
 451   d_v[k] = obj;
 452 }
 453
 454 void
 455 pmt_vector::fill(pmt_t obj)
 456 {
 457   for (size_t i = 0; i < length(); i++)
 458     d_v[i] = obj;
 459 }
 460
 461 bool
 462 pmt_is_vector(pmt_t obj)
 463 {
 464   return obj->is_vector();
 465 }
 466
 467 pmt_t
 468 pmt_make_vector(size_t k, pmt_t fill)
 469 {
 470   return pmt_t(new pmt_vector(k, fill));
 471 }
 472
 473 pmt_t
 474 pmt_vector_ref(pmt_t vector, size_t k)
 475 {
 476   if (!vector->is_vector())
 477     throw pmt_wrong_type("pmt_vector_ref", vector);
 478   return _vector(vector)->ref(k);
 479 }
 480
 481 void
 482 pmt_vector_set(pmt_t vector, size_t k, pmt_t obj)
 483 {
 484   if (!vector->is_vector())
 485     throw pmt_wrong_type("pmt_vector_set", vector);
 486   _vector(vector)->set(k, obj);
 487 }
 488
 489 void
 490 pmt_vector_fill(pmt_t vector, pmt_t obj)
 491 {
 492   if (!vector->is_vector())
 493     throw pmt_wrong_type("pmt_vector_set", vector);
 494   _vector(vector)->fill(obj);
 495 }
 496
 497 ////////////////////////////////////////////////////////////////////////////
 498 //                       Uniform Numeric Vectors
 499 ////////////////////////////////////////////////////////////////////////////
 500
 501 bool
 502 pmt_is_uniform_vector(pmt_t x)
 503 {
 504   return x->is_uniform_vector();
 505 }
 506
 507 const void *
 508 pmt_uniform_vector_elements(pmt_t vector, size_t &len)
 509 {
 510   if (!vector->is_uniform_vector())
 511     throw pmt_wrong_type("pmt_uniform_vector_elements", vector);
 512   return _uniform_vector(vector)->uniform_elements(len);
 513 }
 514
 515 void *
 516 pmt_uniform_vector_writable_elements(pmt_t vector, size_t &len)
 517 {
 518   if (!vector->is_uniform_vector())
 519     throw pmt_wrong_type("pmt_uniform_vector_writable_elements", vector);
 520   return _uniform_vector(vector)->uniform_writable_elements(len);
 521 }
 522
 523 ////////////////////////////////////////////////////////////////////////////
 524 //                            Dictionaries
 525 ////////////////////////////////////////////////////////////////////////////
 526
 527 pmt_dict::pmt_dict()
 528   : d_alist(PMT_NIL)
 529 {
 530 }
 531
 532 void
 533 pmt_dict::set(pmt_t key, pmt_t value)
 534 {
 535   pmt_t p = pmt_assv(key, d_alist);     // look for (key . value) pair
 536   if (pmt_is_pair(p)){                  // found existing pair...
 537     pmt_set_cdr(p, value);              // overrwrite cdr with new value
 538   }
 539   else {                                // not in the dict
 540     d_alist = pmt_cons(pmt_cons(key, value), d_alist);  // add new (key . value) pair
 541   }
 542 }
 543
 544 pmt_t
 545 pmt_dict::ref(pmt_t key, pmt_t not_found) const
 546 {
 547   pmt_t p = pmt_assv(key, d_alist);     // look for (key . value) pair
 548   if (pmt_is_pair(p))
 549     return pmt_cdr(p);
 550   else
 551     return not_found;
 552 }
 553
 554 bool
 555 pmt_dict::has_key(pmt_t key) const
 556 {
 557   return pmt_is_pair(pmt_assv(key, d_alist));
 558 }
 559
 560 pmt_t
 561 pmt_dict::items() const
 562 {
 563   return d_alist;
 564 }
 565
 566 pmt_t
 567 pmt_dict::keys() const
 568 {
 569   return pmt_map(pmt_car, d_alist);
 570 }
 571
 572 pmt_t
 573 pmt_dict::values() const
 574 {
 575   return pmt_map(pmt_cdr, d_alist);
 576 }
 577
 578 bool
 579 pmt_is_dict(pmt_t obj)
 580 {
 581   return obj->is_dict();
 582 }
 583
 584 pmt_t
 585 pmt_make_dict()
 586 {
 587   return pmt_t(new pmt_dict());
 588 }
 589
 590 void
 591 pmt_dict_set(pmt_t dict, pmt_t key, pmt_t value)
 592 {
 593   pmt_dict* d = _dict(dict);
 594   if (!d)
 595     throw pmt_wrong_type("pmt_dict_set", dict);
 596
 597   d->set(key, value);
 598 }
 599
 600 bool
 601 pmt_dict_has_key(pmt_t dict, pmt_t key)
 602 {
 603   pmt_dict* d = _dict(dict);
 604   if (!d)
 605     throw pmt_wrong_type("pmt_dict_has_key", dict);
 606
 607   return d->has_key(key);
 608 }
 609
 610 pmt_t
 611 pmt_dict_ref(pmt_t dict, pmt_t key, pmt_t not_found)
 612 {
 613   pmt_dict* d = _dict(dict);
 614   if (!d)
 615     throw pmt_wrong_type("pmt_dict_ref", dict);
 616
 617   return d->ref(key, not_found);
 618 }
 619
 620 pmt_t
 621 pmt_dict_items(pmt_t dict)
 622 {
 623   if (!dict->is_dict())
 624     throw pmt_wrong_type("pmt_dict_items", dict);
 625
 626   return _dict(dict)->items();
 627 }
 628
 629 pmt_t
 630 pmt_dict_keys(pmt_t dict)
 631 {
 632   if (!dict->is_dict())
 633     throw pmt_wrong_type("pmt_dict_keys", dict);
 634
 635   return _dict(dict)->keys();
 636 }
 637
 638 pmt_t
 639 pmt_dict_values(pmt_t dict)
 640 {
 641   if (!dict->is_dict())
 642     throw pmt_wrong_type("pmt_dict_values", dict);
 643
 644   return _dict(dict)->values();
 645 }
 646
 647 ////////////////////////////////////////////////////////////////////////////
 648 //                                 Any
 649 ////////////////////////////////////////////////////////////////////////////
 650
 651 pmt_any::pmt_any(const boost::any &any) : d_any(any) {}
 652
 653 bool
 654 pmt_is_any(pmt_t obj)
 655 {
 656   return obj->is_any();
 657 }
 658
 659 pmt_t
 660 pmt_make_any(const boost::any &any)
 661 {
 662   return pmt_t(new pmt_any(any));
 663 }
 664
 665 boost::any
 666 pmt_any_ref(pmt_t obj)
 667 {
 668   if (!obj->is_any())
 669     throw pmt_wrong_type("pmt_any_ref", obj);
 670   return _any(obj)->ref();
 671 }
 672
 673 void
 674 pmt_any_set(pmt_t obj, const boost::any &any)
 675 {
 676   if (!obj->is_any())
 677     throw pmt_wrong_type("pmt_any_set", obj);
 678   _any(obj)->set(any);
 679 }
 680
 681 ////////////////////////////////////////////////////////////////////////////
 682 //                          General Functions
 683 ////////////////////////////////////////////////////////////////////////////
 684
 685 bool
 686 pmt_eq(const pmt_t& x, const pmt_t& y)
 687 {
 688   return x == y;
 689 }
 690
 691 bool
 692 pmt_eqv(const pmt_t& x, const pmt_t& y)
 693 {
 694   if (x == y)
 695     return true;
 696
 697   if (x->is_integer() && y->is_integer())
 698     return _integer(x)->value() == _integer(y)->value();
 699
 700   if (x->is_real() && y->is_real())
 701     return _real(x)->value() == _real(y)->value();
 702
 703   if (x->is_complex() && y->is_complex())
 704     return _complex(x)->value() == _complex(y)->value();
 705
 706   return false;
 707 }
 708
 709 bool
 710 pmt_equal(const pmt_t& x, const pmt_t& y)
 711 {
 712   if (pmt_eqv(x, y))
 713     return true;
 714
 715   if (x->is_pair() && y->is_pair())
 716     return pmt_equal(pmt_car(x), pmt_car(y)) && pmt_equal(pmt_cdr(x), pmt_cdr(y));
 717
 718   if (x->is_vector() && y->is_vector()){
 719     pmt_vector *xv = _vector(x);
 720     pmt_vector *yv = _vector(y);
 721     if (xv->length() != yv->length())
 722       return false;
 723
 724     for (unsigned i = 0; i < xv->length(); i++)
 725       if (!pmt_equal(xv->_ref(i), yv->_ref(i)))
 726         return false;
 727
 728     return true;
 729   }
 730
 731   if (x->is_uniform_vector() && y->is_uniform_vector()){
 732     pmt_uniform_vector *xv = _uniform_vector(x);
 733     pmt_uniform_vector *yv = _uniform_vector(y);
 734     if (xv->length() != yv->length())
 735       return false;
 736
 737     size_t len_x, len_y;
 738     if (memcmp(xv->uniform_elements(len_x),
 739                yv->uniform_elements(len_y),
 740                len_x) == 0)
 741       return true;
 742
 743     return true;
 744   }
 745
 746   // FIXME add other cases here...
 747
 748   return false;
 749 }
 750
 751 size_t
 752 pmt_length(const pmt_t& x)
 753 {
 754   if (x->is_vector())
 755     return _vector(x)->length();
 756
 757   if (x->is_uniform_vector())
 758     return _uniform_vector(x)->length();
 759
 760   if (x->is_null()) return 0;
 761
 762   if (x->is_pair()) {
 763     size_t length=1;
 764         pmt_t it = pmt_cdr(x);
 765     while (pmt_is_pair(it)){
 766       length++;
 767       it = pmt_cdr(it);
 768     }
 769     if (pmt_is_null(it))
 770       return length;
 771
 772     // not a proper list
 773     throw pmt_wrong_type("pmt_length", x);
 774   }
 775
 776   // FIXME dictionary length (number of entries)
 777
 778   throw pmt_wrong_type("pmt_length", x);
 779 }
 780
 781 pmt_t
 782 pmt_assq(pmt_t obj, pmt_t alist)
 783 {
 784   while (pmt_is_pair(alist)){
 785     pmt_t p = pmt_car(alist);
 786     if (!pmt_is_pair(p))        // malformed alist
 787       return PMT_F;
 788
 789     if (pmt_eq(obj, pmt_car(p)))
 790       return p;
 791
 792     alist = pmt_cdr(alist);
 793   }
 794   return PMT_F;
 795 }
 796
 797 pmt_t
 798 pmt_assv(pmt_t obj, pmt_t alist)
 799 {
 800   while (pmt_is_pair(alist)){
 801     pmt_t p = pmt_car(alist);
 802     if (!pmt_is_pair(p))        // malformed alist
 803       return PMT_F;
 804
 805     if (pmt_eqv(obj, pmt_car(p)))
 806       return p;
 807
 808     alist = pmt_cdr(alist);
 809   }
 810   return PMT_F;
 811 }
 812
 813 pmt_t
 814 pmt_assoc(pmt_t obj, pmt_t alist)
 815 {
 816   while (pmt_is_pair(alist)){
 817     pmt_t p = pmt_car(alist);
 818     if (!pmt_is_pair(p))        // malformed alist
 819       return PMT_F;
 820
 821     if (pmt_equal(obj, pmt_car(p)))
 822       return p;
 823
 824     alist = pmt_cdr(alist);
 825   }
 826   return PMT_F;
 827 }
 828
 829 pmt_t
 830 pmt_map(pmt_t proc(const pmt_t&), pmt_t list)
 831 {
 832   pmt_t r = PMT_NIL;
 833
 834   while(pmt_is_pair(list)){
 835     r = pmt_cons(proc(pmt_car(list)), r);
 836     list = pmt_cdr(list);
 837   }
 838
 839   return pmt_reverse_x(r);
 840 }
 841
 842 pmt_t
 843 pmt_reverse(pmt_t listx)
 844 {
 845   pmt_t list = listx;
 846   pmt_t r = PMT_NIL;
 847
 848   while(pmt_is_pair(list)){
 849     r = pmt_cons(pmt_car(list), r);
 850     list = pmt_cdr(list);
 851   }
 852   if (pmt_is_null(list))
 853     return r;
 854   else
 855     throw pmt_wrong_type("pmt_reverse", listx);
 856 }
 857
 858 pmt_t
 859 pmt_reverse_x(pmt_t list)
 860 {
 861   // FIXME do it destructively
 862   return pmt_reverse(list);
 863 }
 864
 865 pmt_t
 866 pmt_nth(size_t n, pmt_t list)
 867 {
 868   pmt_t t = pmt_nthcdr(n, list);
 869   if (pmt_is_pair(t))
 870     return pmt_car(t);
 871   else
 872     return PMT_NIL;
 873 }
 874
 875 pmt_t
 876 pmt_nthcdr(size_t n, pmt_t list)
 877 {
 878   if (!(pmt_is_pair(list) || pmt_is_null(list)))
 879     throw pmt_wrong_type("pmt_nthcdr", list);
 880
 881   while (n > 0){
 882     if (pmt_is_pair(list)){
 883       list = pmt_cdr(list);
 884       n--;
 885       continue;
 886     }
 887     if (pmt_is_null(list))
 888       return PMT_NIL;
 889     else
 890       throw pmt_wrong_type("pmt_nthcdr: not a LIST", list);
 891   }
 892   return list;
 893 }
 894
 895 pmt_t
 896 pmt_memq(pmt_t obj, pmt_t list)
 897 {
 898   while (pmt_is_pair(list)){
 899     if (pmt_eq(obj, pmt_car(list)))
 900       return list;
 901     list = pmt_cdr(list);
 902   }
 903   return PMT_F;
 904 }
 905
 906 pmt_t
 907 pmt_memv(pmt_t obj, pmt_t list)
 908 {
 909   while (pmt_is_pair(list)){
 910     if (pmt_eqv(obj, pmt_car(list)))
 911       return list;
 912     list = pmt_cdr(list);
 913   }
 914   return PMT_F;
 915 }
 916
 917 pmt_t
 918 pmt_member(pmt_t obj, pmt_t list)
 919 {
 920   while (pmt_is_pair(list)){
 921     if (pmt_equal(obj, pmt_car(list)))
 922       return list;
 923     list = pmt_cdr(list);
 924   }
 925   return PMT_F;
 926 }
 927
 928 bool
 929 pmt_subsetp(pmt_t list1, pmt_t list2)
 930 {
 931   while (pmt_is_pair(list1)){
 932     pmt_t p = pmt_car(list1);
 933     if (pmt_is_false(pmt_memv(p, list2)))
 934       return false;
 935     list1 = pmt_cdr(list1);
 936   }
 937   return true;
 938 }
 939
 940 pmt_t
 941 pmt_list1(const pmt_t& x1)
 942 {
 943   return pmt_cons(x1, PMT_NIL);
 944 }
 945
 946 pmt_t
 947 pmt_list2(const pmt_t& x1, const pmt_t& x2)
 948 {
 949   return pmt_cons(x1, pmt_cons(x2, PMT_NIL));
 950 }
 951
 952 pmt_t
 953 pmt_list3(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3)
 954 {
 955   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, PMT_NIL)));
 956 }
 957
 958 pmt_t
 959 pmt_list4(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3, const pmt_t& x4)
 960 {
 961   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, PMT_NIL))));
 962 }
 963
 964 pmt_t
 965 pmt_list5(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3, const pmt_t& x4, const pmt_t& x5)
 966 {
 967   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, pmt_cons(x5, PMT_NIL)))));
 968 }
 969
 970 pmt_t
 971 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)
 972 {
 973   return pmt_cons(x1, pmt_cons(x2, pmt_cons(x3, pmt_cons(x4, pmt_cons(x5, pmt_cons(x6, PMT_NIL))))));
 974 }
 975
 976 pmt_t
 977 pmt_list_add(pmt_t list, const pmt_t& item)
 978 {
 979   return pmt_reverse(pmt_cons(item, pmt_reverse(list)));
 980 }
 981
 982 pmt_t
 983 pmt_caar(pmt_t pair)
 984 {
 985   return (pmt_car(pmt_car(pair)));
 986 }
 987
 988 pmt_t
 989 pmt_cadr(pmt_t pair)
 990 {
 991   return pmt_car(pmt_cdr(pair));
 992 }
 993
 994 pmt_t
 995 pmt_cdar(pmt_t pair)
 996 {
 997   return pmt_cdr(pmt_car(pair));
 998 }
 999
1000 pmt_t
1001 pmt_cddr(pmt_t pair)
1002 {
1003   return pmt_cdr(pmt_cdr(pair));
1004 }
1005
1006 pmt_t
1007 pmt_caddr(pmt_t pair)
1008 {
1009   return pmt_car(pmt_cdr(pmt_cdr(pair)));
1010 }
1011
1012 pmt_t
1013 pmt_cadddr(pmt_t pair)
1014 {
1015   return pmt_car(pmt_cdr(pmt_cdr(pmt_cdr(pair))));
1016 }
1017
1018 bool
1019 pmt_is_eof_object(pmt_t obj)
1020 {
1021   return pmt_eq(obj, PMT_EOF);
1022 }
1023
1024 void
1025 pmt_dump_sizeof()
1026 {
1027   printf("sizeof(pmt_t)              = %3zd\n", sizeof(pmt_t));
1028   printf("sizeof(pmt_base)           = %3zd\n", sizeof(pmt_base));
1029   printf("sizeof(pmt_bool)           = %3zd\n", sizeof(pmt_bool));
1030   printf("sizeof(pmt_symbol)         = %3zd\n", sizeof(pmt_symbol));
1031   printf("sizeof(pmt_integer)        = %3zd\n", sizeof(pmt_integer));
1032   printf("sizeof(pmt_real)           = %3zd\n", sizeof(pmt_real));
1033   printf("sizeof(pmt_complex)        = %3zd\n", sizeof(pmt_complex));
1034   printf("sizeof(pmt_null)           = %3zd\n", sizeof(pmt_null));
1035   printf("sizeof(pmt_pair)           = %3zd\n", sizeof(pmt_pair));
1036   printf("sizeof(pmt_vector)         = %3zd\n", sizeof(pmt_vector));
1037   printf("sizeof(pmt_dict)           = %3zd\n", sizeof(pmt_dict));
1038   printf("sizeof(pmt_uniform_vector) = %3zd\n", sizeof(pmt_uniform_vector));
1039 }
1040
1041 } /* namespace pmt */