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