git.gag.com Git - debian/gnuradio/blob - pmt/src/lib/pmt.cc

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