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