-/* -*- c++ -*- */

-/*

- * Copyright 2006,2009,2010 Free Software Foundation, Inc.

- *

- * This file is part of GNU Radio

- *

- * GNU Radio is free software; you can redistribute it and/or modify

- * it under the terms of the GNU General Public License as published by

- * the Free Software Foundation; either version 3, or (at your option)

- * any later version.

- *

- * GNU Radio is distributed in the hope that it will be useful,

- * but WITHOUT ANY WARRANTY; without even the implied warranty of

- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

- * GNU General Public License for more details.

- *

- * You should have received a copy of the GNU General Public License

- * along with GNU Radio; see the file COPYING. If not, write to

- * the Free Software Foundation, Inc., 51 Franklin Street,

- * Boston, MA 02110-1301, USA.

- */

-

-#ifdef HAVE_CONFIG_H

-#include <config.h>

-#endif

-#include <vector>

-#include <gruel/pmt.h>

-#include "pmt_int.h"

-#include <gruel/msg_accepter.h>

-#include <gruel/pmt_pool.h>

-#include <stdio.h>

-#include <string.h>

-

-namespace pmt {

-

-static const int CACHE_LINE_SIZE = 64; // good guess

-

-# if (PMT_LOCAL_ALLOCATOR)

-

-static pmt_pool global_pmt_pool(sizeof(pmt_pair), CACHE_LINE_SIZE);

-

-void *

-pmt_base::operator new(size_t size)

-{

- void *p = global_pmt_pool.malloc();

-

- // fprintf(stderr, "pmt_base::new p = %p\n", p);

- assert((reinterpret_cast<intptr_t>(p) & (CACHE_LINE_SIZE - 1)) == 0);

- return p;

-}

-

-void

-pmt_base::operator delete(void *p, size_t size)

-{

- global_pmt_pool.free(p);

-}

-

-#endif

-

-void intrusive_ptr_add_ref(pmt_base* p) { ++(p->count_); }

-void intrusive_ptr_release(pmt_base* p) { if (--(p->count_) == 0 ) delete p; }

-

-pmt_base::~pmt_base()

-{

- // nop -- out of line virtual destructor

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Exceptions

-////////////////////////////////////////////////////////////////////////////

-

-exception::exception(const std::string &msg, pmt_t obj)

- : logic_error(msg + ": " + write_string(obj))

-{

-}

-

-wrong_type::wrong_type(const std::string &msg, pmt_t obj)

- : exception(msg + ": wrong_type ", obj)

-{

-}

-

-out_of_range::out_of_range(const std::string &msg, pmt_t obj)

- : exception(msg + ": out of range ", obj)

-{

-}

-

-notimplemented::notimplemented(const std::string &msg, pmt_t obj)

- : exception(msg + ": notimplemented ", obj)

-{

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Dynamic Casts

-////////////////////////////////////////////////////////////////////////////

-

-static pmt_symbol *

-_symbol(pmt_t x)

-{

- return dynamic_cast<pmt_symbol*>(x.get());

-}

-

-static pmt_integer *

-_integer(pmt_t x)

-{

- return dynamic_cast<pmt_integer*>(x.get());

-}

-

-static pmt_uint64 *

-_uint64(pmt_t x)

-{

- return dynamic_cast<pmt_uint64*>(x.get());

-}

-

-static pmt_real *

-_real(pmt_t x)

-{

- return dynamic_cast<pmt_real*>(x.get());

-}

-

-static pmt_complex *

-_complex(pmt_t x)

-{

- return dynamic_cast<pmt_complex*>(x.get());

-}

-

-static pmt_pair *

-_pair(pmt_t x)

-{

- return dynamic_cast<pmt_pair*>(x.get());

-}

-

-static pmt_vector *

-_vector(pmt_t x)

-{

- return dynamic_cast<pmt_vector*>(x.get());

-}

-

-static pmt_tuple *

-_tuple(pmt_t x)

-{

- return dynamic_cast<pmt_tuple*>(x.get());

-}

-

-static pmt_uniform_vector *

-_uniform_vector(pmt_t x)

-{

- return dynamic_cast<pmt_uniform_vector*>(x.get());

-}

-

-static pmt_any *

-_any(pmt_t x)

-{

- return dynamic_cast<pmt_any*>(x.get());

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Globals

-////////////////////////////////////////////////////////////////////////////

-

-const pmt_t PMT_T = pmt_t(new pmt_bool()); // singleton

-const pmt_t PMT_F = pmt_t(new pmt_bool()); // singleton

-const pmt_t PMT_NIL = pmt_t(new pmt_null()); // singleton

-const pmt_t PMT_EOF = cons(PMT_NIL, PMT_NIL); // singleton

-

-////////////////////////////////////////////////////////////////////////////

-// Booleans

-////////////////////////////////////////////////////////////////////////////

-

-pmt_bool::pmt_bool(){}

-

-bool

-is_true(pmt_t obj)

-{

- return obj != PMT_F;

-}

-

-bool

-is_false(pmt_t obj)

-{

- return obj == PMT_F;

-}

-

-bool

-is_bool(pmt_t obj)

-{

- return obj->is_bool();

-}

-

-pmt_t

-from_bool(bool val)

-{

- return val ? PMT_T : PMT_F;

-}

-

-bool

-to_bool(pmt_t val)

-{

- if (val == PMT_T)

- return true;

- if (val == PMT_F)

- return false;

- throw wrong_type("pmt_to_bool", val);

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Symbols

-////////////////////////////////////////////////////////////////////////////

-

-static const unsigned int SYMBOL_HASH_TABLE_SIZE = 701;

-static std::vector<pmt_t> s_symbol_hash_table(SYMBOL_HASH_TABLE_SIZE);

-

-pmt_symbol::pmt_symbol(const std::string &name) : d_name(name){}

-

-

-static unsigned int

-hash_string(const std::string &s)

-{

- unsigned int h = 0;

- unsigned int g = 0;

-

- for (std::string::const_iterator p = s.begin(); p != s.end(); ++p){

- h = (h << 4) + (*p & 0xff);

- g = h & 0xf0000000;

- if (g){

- h = h ^ (g >> 24);

- h = h ^ g;

- }

- }

- return h;

-}

-

-bool

-is_symbol(const pmt_t& obj)

-{

- return obj->is_symbol();

-}

-

-pmt_t

-string_to_symbol(const std::string &name)

-{

- unsigned hash = hash_string(name) % SYMBOL_HASH_TABLE_SIZE;

-

- // Does a symbol with this name already exist?

- for (pmt_t sym = s_symbol_hash_table[hash]; sym; sym = _symbol(sym)->next()){

- if (name == _symbol(sym)->name())

- return sym; // Yes. Return it

- }

-

- // Nope. Make a new one.

- pmt_t sym = pmt_t(new pmt_symbol(name));

- _symbol(sym)->set_next(s_symbol_hash_table[hash]);

- s_symbol_hash_table[hash] = sym;

- return sym;

-}

-

-// alias...

-pmt_t

-intern(const std::string &name)

-{

- return string_to_symbol(name);

-}

-

-const std::string

-symbol_to_string(const pmt_t& sym)

-{

- if (!sym->is_symbol())

- throw wrong_type("pmt_symbol_to_string", sym);

-

- return _symbol(sym)->name();

-}

-

-

-

-////////////////////////////////////////////////////////////////////////////

-// Number

-////////////////////////////////////////////////////////////////////////////

-

-bool

-is_number(pmt_t x)

-{

- return x->is_number();

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Integer

-////////////////////////////////////////////////////////////////////////////

-

-pmt_integer::pmt_integer(long value) : d_value(value) {}

-

-bool

-is_integer(pmt_t x)

-{

- return x->is_integer();

-}

-

-

-pmt_t

-from_long(long x)

-{

- return pmt_t(new pmt_integer(x));

-}

-

-long

-to_long(pmt_t x)

-{

- pmt_integer* i = dynamic_cast<pmt_integer*>(x.get());

- if ( i )

- return i->value();

-

- throw wrong_type("pmt_to_long", x);

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Uint64

-////////////////////////////////////////////////////////////////////////////

-

-pmt_uint64::pmt_uint64(uint64_t value) : d_value(value) {}

-

-bool

-is_uint64(pmt_t x)

-{

- return x->is_uint64();

-}

-

-

-pmt_t

-from_uint64(uint64_t x)

-{

- return pmt_t(new pmt_uint64(x));

-}

-

-uint64_t

-to_uint64(pmt_t x)

-{

- if(x->is_uint64())

- return _uint64(x)->value();

- if(x->is_integer())

- {

- long tmp = _integer(x)->value();

- if(tmp >= 0)

- return (uint64_t) tmp;

- }

-

- throw wrong_type("pmt_to_uint64", x);

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Real

-////////////////////////////////////////////////////////////////////////////

-

-pmt_real::pmt_real(double value) : d_value(value) {}

-

-bool

-is_real(pmt_t x)

-{

- return x->is_real();

-}

-

-pmt_t

-from_double(double x)

-{

- return pmt_t(new pmt_real(x));

-}

-

-double

-to_double(pmt_t x)

-{

- if (x->is_real())

- return _real(x)->value();

- if (x->is_integer())

- return _integer(x)->value();

-

- throw wrong_type("pmt_to_double", x);

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Complex

-////////////////////////////////////////////////////////////////////////////

-

-pmt_complex::pmt_complex(std::complex<double> value) : d_value(value) {}

-

-bool

-is_complex(pmt_t x)

-{

- return x->is_complex();

-}

-

-pmt_t

-make_rectangular(double re, double im)

-{

- return from_complex(re, im);

-}

-

-pmt_t

-from_complex(double re, double im)

-{

- return pmt_from_complex(re, im);

-}

-

-pmt_t pmt_from_complex(double re, double im)

-{

- return pmt_t(new pmt_complex(std::complex<double>(re, im)));

-}

-

-pmt_t

-from_complex(const std::complex<double> &z)

-{

- return pmt_t(new pmt_complex(z));

-}

-

-std::complex<double>

-to_complex(pmt_t x)

-{

- if (x->is_complex())

- return _complex(x)->value();

- if (x->is_real())

- return _real(x)->value();

- if (x->is_integer())

- return _integer(x)->value();

-

- throw wrong_type("pmt_to_complex", x);

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Pairs

-////////////////////////////////////////////////////////////////////////////

-

-pmt_null::pmt_null() {}

-pmt_pair::pmt_pair(const pmt_t& car, const pmt_t& cdr) : d_car(car), d_cdr(cdr) {}

-

-bool

-is_null(const pmt_t& x)

-{

- return x == PMT_NIL;

-}

-

-bool

-is_pair(const pmt_t& obj)

-{

- return obj->is_pair();

-}

-

-pmt_t

-cons(const pmt_t& x, const pmt_t& y)

-{

- return pmt_t(new pmt_pair(x, y));

-}

-

-pmt_t

-car(const pmt_t& pair)

-{

- pmt_pair* p = dynamic_cast<pmt_pair*>(pair.get());

- if ( p )

- return p->car();

-

- throw wrong_type("pmt_car", pair);

-}

-

-pmt_t

-cdr(const pmt_t& pair)

-{

- pmt_pair* p = dynamic_cast<pmt_pair*>(pair.get());

- if ( p )

- return p->cdr();

-

- throw wrong_type("pmt_cdr", pair);

-}

-

-void

-set_car(pmt_t pair, pmt_t obj)

-{

- if (pair->is_pair())

- _pair(pair)->set_car(obj);

- else

- throw wrong_type("pmt_set_car", pair);

-}

-

-void

-set_cdr(pmt_t pair, pmt_t obj)

-{

- if (pair->is_pair())

- _pair(pair)->set_cdr(obj);

- else

- throw wrong_type("pmt_set_cdr", pair);

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Vectors

-////////////////////////////////////////////////////////////////////////////

-

-pmt_vector::pmt_vector(size_t len, pmt_t fill)

- : d_v(len)

-{

- for (size_t i = 0; i < len; i++)

- d_v[i] = fill;

-}

-

-pmt_t

-pmt_vector::ref(size_t k) const

-{

- if (k >= length())

- throw out_of_range("pmt_vector_ref", from_long(k));

- return d_v[k];

-}

-

-void

-pmt_vector::set(size_t k, pmt_t obj)

-{

- if (k >= length())

- throw out_of_range("pmt_vector_set", from_long(k));

- d_v[k] = obj;

-}

-

-void

-pmt_vector::fill(pmt_t obj)

-{

- for (size_t i = 0; i < length(); i++)

- d_v[i] = obj;

-}

-

-bool

-is_vector(pmt_t obj)

-{

- return obj->is_vector();

-}

-

-pmt_t

-make_vector(size_t k, pmt_t fill)

-{

- return pmt_t(new pmt_vector(k, fill));

-}

-

-pmt_t

-vector_ref(pmt_t vector, size_t k)

-{

- if (!vector->is_vector())

- throw wrong_type("pmt_vector_ref", vector);

- return _vector(vector)->ref(k);

-}

-

-void

-vector_set(pmt_t vector, size_t k, pmt_t obj)

-{

- if (!vector->is_vector())

- throw wrong_type("pmt_vector_set", vector);

- _vector(vector)->set(k, obj);

-}

-

-void

-vector_fill(pmt_t vector, pmt_t obj)

-{

- if (!vector->is_vector())

- throw wrong_type("pmt_vector_set", vector);

- _vector(vector)->fill(obj);

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Tuples

-////////////////////////////////////////////////////////////////////////////

-

-pmt_tuple::pmt_tuple(size_t len)

- : d_v(len)

-{

-}

-

-pmt_t

-pmt_tuple::ref(size_t k) const

-{

- if (k >= length())

- throw out_of_range("pmt_tuple_ref", from_long(k));

- return d_v[k];

-}

-

-bool

-is_tuple(pmt_t obj)

-{

- return obj->is_tuple();

-}

-

-pmt_t

-tuple_ref(const pmt_t &tuple, size_t k)

-{

- if (!tuple->is_tuple())

- throw wrong_type("pmt_tuple_ref", tuple);

- return _tuple(tuple)->ref(k);

-}

-

-// for (i=0; i < 10; i++)

-// make_constructor()

-

-pmt_t

-make_tuple()

-{

- return pmt_t(new pmt_tuple(0));

-}

-

-pmt_t

-make_tuple(const pmt_t &e0)

-{

- pmt_tuple *t = new pmt_tuple(1);

- t->_set(0, e0);

- return pmt_t(t);

-}

-

-pmt_t

-make_tuple(const pmt_t &e0, const pmt_t &e1)

-{

- pmt_tuple *t = new pmt_tuple(2);

- t->_set(0, e0);

- t->_set(1, e1);

- return pmt_t(t);

-}

-

-pmt_t

-make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2)

-{

- pmt_tuple *t = new pmt_tuple(3);

- t->_set(0, e0);

- t->_set(1, e1);

- t->_set(2, e2);

- return pmt_t(t);

-}

-

-pmt_t

-make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3)

-{

- pmt_tuple *t = new pmt_tuple(4);

- t->_set(0, e0);

- t->_set(1, e1);

- t->_set(2, e2);

- t->_set(3, e3);

- return pmt_t(t);

-}

-

-pmt_t

-make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4)

-{

- pmt_tuple *t = new pmt_tuple(5);

- t->_set(0, e0);

- t->_set(1, e1);

- t->_set(2, e2);

- t->_set(3, e3);

- t->_set(4, e4);

- return pmt_t(t);

-}

-

-pmt_t

-make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4, const pmt_t &e5)

-{

- pmt_tuple *t = new pmt_tuple(6);

- t->_set(0, e0);

- t->_set(1, e1);

- t->_set(2, e2);

- t->_set(3, e3);

- t->_set(4, e4);

- t->_set(5, e5);

- return pmt_t(t);

-}

-

-pmt_t

-make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4, const pmt_t &e5, const pmt_t &e6)

-{

- pmt_tuple *t = new pmt_tuple(7);

- t->_set(0, e0);

- t->_set(1, e1);

- t->_set(2, e2);

- t->_set(3, e3);

- t->_set(4, e4);

- t->_set(5, e5);

- t->_set(6, e6);

- return pmt_t(t);

-}

-

-pmt_t

-make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4, const pmt_t &e5, const pmt_t &e6, const pmt_t &e7)

-{

- pmt_tuple *t = new pmt_tuple(8);

- t->_set(0, e0);

- t->_set(1, e1);

- t->_set(2, e2);

- t->_set(3, e3);

- t->_set(4, e4);

- t->_set(5, e5);

- t->_set(6, e6);

- t->_set(7, e7);

- return pmt_t(t);

-}

-

-pmt_t

-make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4, const pmt_t &e5, const pmt_t &e6, const pmt_t &e7, const pmt_t &e8)

-{

- pmt_tuple *t = new pmt_tuple(9);

- t->_set(0, e0);

- t->_set(1, e1);

- t->_set(2, e2);

- t->_set(3, e3);

- t->_set(4, e4);

- t->_set(5, e5);

- t->_set(6, e6);

- t->_set(7, e7);

- t->_set(8, e8);

- return pmt_t(t);

-}

-

-pmt_t

-make_tuple(const pmt_t &e0, const pmt_t &e1, const pmt_t &e2, const pmt_t &e3, const pmt_t &e4, const pmt_t &e5, const pmt_t &e6, const pmt_t &e7, const pmt_t &e8, const pmt_t &e9)

-{

- pmt_tuple *t = new pmt_tuple(10);

- t->_set(0, e0);

- t->_set(1, e1);

- t->_set(2, e2);

- t->_set(3, e3);

- t->_set(4, e4);

- t->_set(5, e5);

- t->_set(6, e6);

- t->_set(7, e7);

- t->_set(8, e8);

- t->_set(9, e9);

- return pmt_t(t);

-}

-

-pmt_t

-to_tuple(const pmt_t &x)

-{

- if (x->is_tuple()) // already one

- return x;

-

- size_t len = length(x);

- pmt_tuple *t = new pmt_tuple(len);

- pmt_t r = pmt_t(t);

-

- if (x->is_vector()){

- for (size_t i = 0; i < len; i++)

- t->_set(i, _vector(x)->ref(i));

- return r;

- }

-

- if (x->is_pair()){

- pmt_t y = x;

- for (size_t i = 0; i < len; i++){

- t->_set(i, car(y));

- y = cdr(y);

- }

- return r;

- }

-

- throw wrong_type("pmt_to_tuple", x);

-}

-

-

-

-////////////////////////////////////////////////////////////////////////////

-// Uniform Numeric Vectors

-////////////////////////////////////////////////////////////////////////////

-

-bool

-is_uniform_vector(pmt_t x)

-{

- return x->is_uniform_vector();

-}

-

-const void *

-uniform_vector_elements(pmt_t vector, size_t &len)

-{

- if (!vector->is_uniform_vector())

- throw wrong_type("pmt_uniform_vector_elements", vector);

- return _uniform_vector(vector)->uniform_elements(len);

-}

-

-void *

-uniform_vector_writable_elements(pmt_t vector, size_t &len)

-{

- if (!vector->is_uniform_vector())

- throw wrong_type("pmt_uniform_vector_writable_elements", vector);

- return _uniform_vector(vector)->uniform_writable_elements(len);

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Dictionaries

-////////////////////////////////////////////////////////////////////////////

-

-/*

- * This is an a-list implementation.

- *

- * When we need better performance for large dictionaries, consider implementing

- * persistent Red-Black trees as described in "Purely Functional Data Structures",

- * Chris Okasaki, 1998, section 3.3.

- */

-

-bool

-is_dict(const pmt_t &obj)

-{

- return is_null(obj) || is_pair(obj);

-}

-

-pmt_t

-make_dict()

-{

- return PMT_NIL;

-}

-

-pmt_t

-dict_add(const pmt_t &dict, const pmt_t &key, const pmt_t &value)

-{

- if (is_null(dict))

- return acons(key, value, PMT_NIL);

-

- if (dict_has_key(dict, key))

- return acons(key, value, dict_delete(dict, key));

-

- return acons(key, value, dict);

-}

-

-pmt_t

-dict_delete(const pmt_t &dict, const pmt_t &key)

-{

- if (is_null(dict))

- return dict;

-

- if (eqv(caar(dict), key))

- return cdr(dict);

-

- return cons(car(dict), dict_delete(cdr(dict), key));

-}

-

-pmt_t

-dict_ref(const pmt_t &dict, const pmt_t &key, const pmt_t &not_found)

-{

- pmt_t p = assv(key, dict); // look for (key . value) pair

- if (is_pair(p))

- return cdr(p);

- else

- return not_found;

-}

-

-bool

-dict_has_key(const pmt_t &dict, const pmt_t &key)

-{

- return is_pair(assv(key, dict));

-}

-

-pmt_t

-dict_items(pmt_t dict)

-{

- if (!is_dict(dict))

- throw wrong_type("pmt_dict_values", dict);

-

- return dict; // equivalent to dict in the a-list case

-}

-

-pmt_t

-dict_keys(pmt_t dict)

-{

- if (!is_dict(dict))

- throw wrong_type("pmt_dict_keys", dict);

-

- return map(car, dict);

-}

-

-pmt_t

-dict_values(pmt_t dict)

-{

- if (!is_dict(dict))

- throw wrong_type("pmt_dict_keys", dict);

-

- return map(cdr, dict);

-}

-

-////////////////////////////////////////////////////////////////////////////

-// Any

-////////////////////////////////////////////////////////////////////////////

-

-pmt_any::pmt_any(const boost::any &any) : d_any(any) {}

-

-bool

-is_any(pmt_t obj)

-{

- return obj->is_any();

-}

-

-pmt_t

-make_any(const boost::any &any)

-{

- return pmt_t(new pmt_any(any));

-}

-

-boost::any

-any_ref(pmt_t obj)

-{

- if (!obj->is_any())

- throw wrong_type("pmt_any_ref", obj);

- return _any(obj)->ref();

-}

-

-void

-any_set(pmt_t obj, const boost::any &any)

-{

- if (!obj->is_any())

- throw wrong_type("pmt_any_set", obj);

- _any(obj)->set(any);

-}

-

-////////////////////////////////////////////////////////////////////////////

-// msg_accepter -- built from "any"

-////////////////////////////////////////////////////////////////////////////

-

-bool

-is_msg_accepter(const pmt_t &obj)

-{

- if (!is_any(obj))

- return false;

-

- boost::any r = any_ref(obj);

- return boost::any_cast<gruel::msg_accepter_sptr>(&r) != 0;

-}

-

-//! make a msg_accepter

-pmt_t

-make_msg_accepter(gruel::msg_accepter_sptr ma)

-{

- return make_any(ma);

-}

-

-//! Return underlying msg_accepter

-gruel::msg_accepter_sptr

-msg_accepter_ref(const pmt_t &obj)

-{

- try {

- return boost::any_cast<gruel::msg_accepter_sptr>(any_ref(obj));

- }

- catch (boost::bad_any_cast &e){

- throw wrong_type("pmt_msg_accepter_ref", obj);

- }

-}

-

-

-////////////////////////////////////////////////////////////////////////////

-// Binary Large Object -- currently a u8vector

-////////////////////////////////////////////////////////////////////////////

-

-bool

-is_blob(pmt_t x)

-{

- // return is_u8vector(x);

- return is_uniform_vector(x);

-}

-

-pmt_t

-make_blob(const void *buf, size_t len_in_bytes)

-{

- return init_u8vector(len_in_bytes, (const uint8_t *) buf);

-}

-

-const void *

-blob_data(pmt_t blob)

-{

- size_t len;

- return uniform_vector_elements(blob, len);

-}

-

-size_t

-blob_length(pmt_t blob)

-{

- size_t len;

- uniform_vector_elements(blob, len);

- return len;

-}

-

-

-////////////////////////////////////////////////////////////////////////////

-// General Functions

-////////////////////////////////////////////////////////////////////////////

-

-bool

-eq(const pmt_t& x, const pmt_t& y)

-{

- return x == y;

-}

-

-bool

-eqv(const pmt_t& x, const pmt_t& y)

-{

- if (x == y)

- return true;

-

- if (x->is_integer() && y->is_integer())

- return _integer(x)->value() == _integer(y)->value();

-

- if (x->is_uint64() && y->is_uint64())

- return _uint64(x)->value() == _uint64(y)->value();

-

- if (x->is_real() && y->is_real())

- return _real(x)->value() == _real(y)->value();

-

- if (x->is_complex() && y->is_complex())

- return _complex(x)->value() == _complex(y)->value();

-

- return false;

-}

-

-bool

-eqv_raw(pmt_base *x, pmt_base *y)

-{

- if (x == y)

- return true;

-

- if (x->is_integer() && y->is_integer())

- return _integer(x)->value() == _integer(y)->value();

-

- if (x->is_uint64() && y->is_uint64())

- return _uint64(x)->value() == _uint64(y)->value();

-

- if (x->is_real() && y->is_real())

- return _real(x)->value() == _real(y)->value();

-

- if (x->is_complex() && y->is_complex())

- return _complex(x)->value() == _complex(y)->value();

-

- return false;

-}

-

-bool

-equal(const pmt_t& x, const pmt_t& y)

-{

- if (eqv(x, y))

- return true;

-

- if (x->is_pair() && y->is_pair())

- return equal(car(x), car(y)) && equal(cdr(x), cdr(y));

-

- if (x->is_vector() && y->is_vector()){

- pmt_vector *xv = _vector(x);

- pmt_vector *yv = _vector(y);

- if (xv->length() != yv->length())

- return false;

-

- for (unsigned i = 0; i < xv->length(); i++)

- if (!equal(xv->_ref(i), yv->_ref(i)))

- return false;

-

- return true;

- }

-

- if (x->is_tuple() && y->is_tuple()){

- pmt_tuple *xv = _tuple(x);

- pmt_tuple *yv = _tuple(y);

- if (xv->length() != yv->length())

- return false;

-

- for (unsigned i = 0; i < xv->length(); i++)

- if (!equal(xv->_ref(i), yv->_ref(i)))

- return false;

-

- return true;

- }

-

- if (x->is_uniform_vector() && y->is_uniform_vector()){

- pmt_uniform_vector *xv = _uniform_vector(x);

- pmt_uniform_vector *yv = _uniform_vector(y);

- if (xv->length() != yv->length())

- return false;

-

- size_t len_x, len_y;

- if (memcmp(xv->uniform_elements(len_x),

- yv->uniform_elements(len_y),

- len_x) == 0)

- return true;

-

- return true;

- }

-

- // FIXME add other cases here...

-

- return false;

-}

-

-size_t

-length(const pmt_t& x)

-{

- if (x->is_vector())

- return _vector(x)->length();

-

- if (x->is_uniform_vector())

- return _uniform_vector(x)->length();

-

- if (x->is_tuple())

- return _tuple(x)->length();

-

- if (x->is_null())

- return 0;

-

- if (x->is_pair()) {

- size_t length=1;

- pmt_t it = cdr(x);

- while (is_pair(it)){

- length++;

- it = cdr(it);

- }

- if (is_null(it))

- return length;

-

- // not a proper list

- throw wrong_type("pmt_length", x);

- }

-

- // FIXME dictionary length (number of entries)

-

- throw wrong_type("pmt_length", x);

-}

-

-pmt_t

-assq(pmt_t obj, pmt_t alist)

-{

- while (is_pair(alist)){

- pmt_t p = car(alist);

- if (!is_pair(p)) // malformed alist

- return PMT_F;

-

- if (eq(obj, car(p)))

- return p;

-

- alist = cdr(alist);

- }

- return PMT_F;

-}

-

-/*

- * This avoids a bunch of shared_pointer reference count manipulation.

- */

-pmt_t

-assv_raw(pmt_base *obj, pmt_base *alist)

-{

- while (alist->is_pair()){

- pmt_base *p = ((pmt_pair *)alist)->d_car.get();

- if (!p->is_pair()) // malformed alist

- return PMT_F;

-

- if (eqv_raw(obj, ((pmt_pair *)p)->d_car.get()))

- return ((pmt_pair *)alist)->d_car;

-

- alist = (((pmt_pair *)alist)->d_cdr).get();

- }

- return PMT_F;

-}

-

-#if 1

-

-pmt_t

-assv(pmt_t obj, pmt_t alist)

-{

- return assv_raw(obj.get(), alist.get());

-}

-

-#else

-

-pmt_t

-assv(pmt_t obj, pmt_t alist)

-{

- while (is_pair(alist)){

- pmt_t p = car(alist);

- if (!is_pair(p)) // malformed alist

- return PMT_F;

-

- if (eqv(obj, car(p)))

- return p;

-

- alist = cdr(alist);

- }

- return PMT_F;

-}

-

-#endif

-

-

-pmt_t

-assoc(pmt_t obj, pmt_t alist)

-{

- while (is_pair(alist)){

- pmt_t p = car(alist);

- if (!is_pair(p)) // malformed alist

- return PMT_F;

-

- if (equal(obj, car(p)))

- return p;

-

- alist = cdr(alist);

- }

- return PMT_F;

-}

-

-pmt_t

-map(pmt_t proc(const pmt_t&), pmt_t list)

-{

- pmt_t r = PMT_NIL;

-

- while(is_pair(list)){

- r = cons(proc(car(list)), r);

- list = cdr(list);

- }

-

- return reverse_x(r);

-}

-

-pmt_t

-reverse(pmt_t listx)

-{

- pmt_t list = listx;

- pmt_t r = PMT_NIL;

-

- while(is_pair(list)){

- r = cons(car(list), r);

- list = cdr(list);

- }

- if (is_null(list))

- return r;

- else

- throw wrong_type("pmt_reverse", listx);

-}

-

-pmt_t

-reverse_x(pmt_t list)

-{

- // FIXME do it destructively

- return reverse(list);

-}

-

-pmt_t

-nth(size_t n, pmt_t list)

-{

- pmt_t t = nthcdr(n, list);

- if (is_pair(t))

- return car(t);

- else

- return PMT_NIL;

-}

-

-pmt_t

-nthcdr(size_t n, pmt_t list)

-{

- if (!(is_pair(list) || is_null(list)))

- throw wrong_type("pmt_nthcdr", list);

-

- while (n > 0){

- if (is_pair(list)){

- list = cdr(list);

- n--;

- continue;

- }

- if (is_null(list))

- return PMT_NIL;

- else

- throw wrong_type("pmt_nthcdr: not a LIST", list);

- }

- return list;

-}

-

-pmt_t

-memq(pmt_t obj, pmt_t list)

-{

- while (is_pair(list)){

- if (eq(obj, car(list)))

- return list;

- list = cdr(list);

- }

- return PMT_F;

-}

-

-pmt_t

-memv(pmt_t obj, pmt_t list)

-{

- while (is_pair(list)){

- if (eqv(obj, car(list)))

- return list;

- list = cdr(list);

- }

- return PMT_F;

-}

-

-pmt_t

-member(pmt_t obj, pmt_t list)

-{

- while (is_pair(list)){

- if (equal(obj, car(list)))

- return list;

- list = cdr(list);

- }

- return PMT_F;

-}

-

-bool

-subsetp(pmt_t list1, pmt_t list2)

-{

- while (is_pair(list1)){

- pmt_t p = car(list1);

- if (is_false(memv(p, list2)))

- return false;

- list1 = cdr(list1);

- }

- return true;

-}

-

-pmt_t

-list1(const pmt_t& x1)

-{

- return cons(x1, PMT_NIL);

-}

-

-pmt_t

-list2(const pmt_t& x1, const pmt_t& x2)

-{

- return cons(x1, cons(x2, PMT_NIL));

-}

-

-pmt_t

-list3(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3)

-{

- return cons(x1, cons(x2, cons(x3, PMT_NIL)));

-}

-

-pmt_t

-list4(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3, const pmt_t& x4)

-{

- return cons(x1, cons(x2, cons(x3, cons(x4, PMT_NIL))));

-}

-

-pmt_t

-list5(const pmt_t& x1, const pmt_t& x2, const pmt_t& x3, const pmt_t& x4, const pmt_t& x5)

-{

- return cons(x1, cons(x2, cons(x3, cons(x4, cons(x5, PMT_NIL)))));

-}

-

-pmt_t

-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)

-{

- return cons(x1, cons(x2, cons(x3, cons(x4, cons(x5, cons(x6, PMT_NIL))))));

-}

-

-pmt_t

-list_add(pmt_t list, const pmt_t& item)

-{

- return reverse(cons(item, reverse(list)));

-}

-

-pmt_t

-list_rm(pmt_t list, const pmt_t& item)

-{

- if(is_pair(list)){

- pmt_t left = car(list);

- pmt_t right = cdr(list);

- if(!equal(left, item)){

- return cons(left, list_rm(right, item));

- } else {

- return list_rm(right, item);

- }

- } else {

- return list;

- }

-}

-

-bool

-list_has(pmt_t list, const pmt_t& item)

-{

- if(is_pair(list)){

- pmt_t left = car(list);

- pmt_t right = cdr(list);

- if(equal(left,item))

- return true;

- return list_has(right, item);

- } else {

- if(is_null(list))

- return false;

- throw std::runtime_error("list contains invalid format!");

- }

-}

-

-pmt_t

-caar(pmt_t pair)

-{

- return (car(car(pair)));

-}

-

-pmt_t

-cadr(pmt_t pair)

-{

- return car(cdr(pair));

-}

-

-pmt_t

-cdar(pmt_t pair)

-{

- return cdr(car(pair));

-}

-

-pmt_t

-cddr(pmt_t pair)

-{

- return cdr(cdr(pair));

-}

-

-pmt_t

-caddr(pmt_t pair)

-{

- return car(cdr(cdr(pair)));

-}

-

-pmt_t

-cadddr(pmt_t pair)

-{

- return car(cdr(cdr(cdr(pair))));

-}

-

-bool

-is_eof_object(pmt_t obj)

-{

- return eq(obj, PMT_EOF);

-}

-

-void

-dump_sizeof()

-{

- printf("sizeof(pmt_t) = %3zd\n", sizeof(pmt_t));

- printf("sizeof(pmt_base) = %3zd\n", sizeof(pmt_base));

- printf("sizeof(pmt_bool) = %3zd\n", sizeof(pmt_bool));

- printf("sizeof(pmt_symbol) = %3zd\n", sizeof(pmt_symbol));

- printf("sizeof(pmt_integer) = %3zd\n", sizeof(pmt_integer));

- printf("sizeof(pmt_uint64) = %3zd\n", sizeof(pmt_uint64));

- printf("sizeof(pmt_real) = %3zd\n", sizeof(pmt_real));

- printf("sizeof(pmt_complex) = %3zd\n", sizeof(pmt_complex));

- printf("sizeof(pmt_null) = %3zd\n", sizeof(pmt_null));

- printf("sizeof(pmt_pair) = %3zd\n", sizeof(pmt_pair));

- printf("sizeof(pmt_vector) = %3zd\n", sizeof(pmt_vector));

- printf("sizeof(pmt_uniform_vector) = %3zd\n", sizeof(pmt_uniform_vector));

-}

-

-} /* namespace pmt */