bool Ty::aEquiv (TyPtr other) const
{
if (kind != other->kind)
return false;
switch (kind)
{
case tyPoly:
return true;
case tyConcrete:
if (name != other->name)
return false;
for (auto s1 = subtypes, s2 = other->subtypes; ; ++s1, ++s2)
if (s1.nil() && s2.nil())
return true;
else if (s1.nil() || s2.nil())
return false;
else
if (!s1.head()->aEquiv(s2.head()))
return false;
default:
return false;
}
}
int main () {
initHeap();
List * list = nil();
int i, j;
for (i = 0; i < 5; i++) {
List * inner = nil();
for (j = 0; j < 5; j++)
{
Position * p = alloc(sizeof(Position), NULL, NULL);
inner = cons((void *)p, inner);
}
list = cons((void *)inner, list);
}
printHeap(HEAP);
printf("%d\n", heapSize(HEAP));
release((void *)list);
printf("========\n");
printHeap(HEAP);
return 0;
}
Compatible::Compatible(Query* s1, Query* s2)
: Query2(s1, s2),
allcols(set_union(source->columns(), source2->columns())) {
Lisp<Fixed> fixed1 = source->fixed();
Lisp<Fixed> fixed2 = source2->fixed();
Lisp<Fixed> f1;
Lisp<Fixed> f2;
for (f1 = fixed1; !nil(f1); ++f1)
for (f2 = fixed2; !nil(f2); ++f2)
if (f1->field == f2->field &&
nil(intersect(f1->values, f2->values))) {
disjoint = f1->field;
return;
}
Fields cols2 = source2->columns();
for (f1 = fixed1; !nil(f1); ++f1)
if (!member(cols2, f1->field) && !member(f1->values, SuEmptyString)) {
disjoint = f1->field;
return;
}
Fields cols1 = source->columns();
for (f2 = fixed2; !nil(f2); ++f2)
if (!member(cols1, f2->field) && !member(f2->values, SuEmptyString)) {
disjoint = f2->field;
return;
}
}
cons_t* proc_env_assign(cons_t* p, environment_t*)
{
assert_length(p, 3);
assert_type(ENVIRONMENT, car(p));
assert_type(SYMBOL, cadr(p));
const std::string name = symbol_name(cadr(p));
environment_t *e = car(p)->environment;
cons_t *value = caddr(p);
if ( value == NULL )
raise(runtime_exception(
"Symbol is not bound in any environment: " + name));
environment_t *i = e;
// search for definition and set if found
for ( ; i != NULL; i = i->outer ) {
if ( i->symbols.find(name) != i->symbols.end() ) {
i->symbols[name] = value;
return nil();
}
}
// only set if NOT found
if ( i == NULL )
e->define(name, value);
return nil();
}
Indexes Project::keys()
{
Indexes keys;
for (Indexes k = source->keys(); ! nil(k); ++k)
if (subset(flds, *k))
keys.push(*k);
return nil(keys) ? Indexes(flds) : keys;
}
unsigned long getSeq()
{
char seqfile[FILENAME_MAX];
FILE *stream;
unsigned long seq = 0;
mkfilename(seqfile, E_spooldir, SFILENAME);
if ((stream = FOPEN(seqfile, "r+", IMAGE_MODE)) == nil(FILE))
{
printerr( seqfile );
if ((stream = FOPEN(seqfile, "w", IMAGE_MODE)) == nil(FILE))
{
printerr( seqfile );
panic();
}
}
else {
if ( fread( &seq, sizeof seq, 1, stream ) != 1 )
printerr( seqfile );
}
/*--------------------------------------------------------------------*/
/* Generate a new seed for our sequence if we can't read one */
/*--------------------------------------------------------------------*/
if ( ! seq++ )
{
seq = ((unsigned long) getpid()) % 10000000;
/* Start number small, semi-unique*/
printmsg(0,"Resetting sequence number to %lu (0x%08lx)",
seq,
seq );
}
/*--------------------------------------------------------------------*/
/* Update sequence number */
/*--------------------------------------------------------------------*/
rewind( stream );
if ((fwrite( &seq, sizeof seq, 1, stream ) != 1) || fclose(stream))
{
printerr( seqfile );
panic();
}
#ifdef UDEBUG
printmsg(8, "getseq: seq#=%ld", seq);
#endif
return seq;
} /* getseq */
Expr* ListLastBefore(Expr* expr){
if(expr->next == NULL){
return nil();
}else if(expr->next->type == Null_Exp){
return expr;
}else if(expr->next->type != Pair_Exp){
return nil();
}else if(expr->next->type == Pair_Exp){
return ListLastBefore(expr->next);
}
}
bool symbol::is_useless() const
{
assert(m_property_list);
if((!m_value || m_value == nil()) &&
(!m_function || m_function == nil()) && m_property_list == nil())
//&& !m_gc_flag)
return true;
return false;
}
/*
* (fclose <file-obj>)
*/
cons_t* proc_fclose(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_pointer("FILE*", car(p));
FILE *f = reinterpret_cast<FILE*>(car(p)->pointer->value);
return !fclose(f)? nil() : boolean(false);
}
void update_stack_frame(StackFrame* frame, Scope* scope) {
frame->scope = scope;
if (scope)
{
if (scope->locals())
frame->locals = scope->locals()->data();
else
frame->locals = NULL;
if (scope->arguments()) {
scope->arguments()->preallocate(scope->local_map()->num_arguments());
frame->args = scope->arguments()->data();
frame->num_args = scope->arguments()->length();
} else {
frame->args = NULL;
frame->num_args = 0;
}
frame->self = scope->self().value();
frame->it = scope->arguments() && scope->arguments()->length() > 0 ? scope->arguments()->get_by_index(0).value() : nil();
} else {
frame->locals = NULL;
frame->args = NULL;
frame->num_args = 0;
frame->self = NULL;
frame->it = nil();
}
}
/*
* (set-video-mode <width> <height> <bits per pixel>?) or
* (set-video-mode <width> <height> <bits per pixel> <mode flags>+)
*
* where <symbols> are:
* swsurface
* hwsurface
* asyncblit
* anyformat
* hwpalette
* doublebuf
* fullscreen
* opengl
* openglblit
* resizable
* noframe
*
*/
cons_t* set_video_mode(cons_t* p, environment_t*)
{
assert_length_min(p, 2);
assert_type(INTEGER, car(p));
assert_type(INTEGER, cadr(p));
// dimension
int x = car(p)->integer;
int y = cadr(p)->integer;
// default values
int bits = 32;
uint32_t mode = 0;
///////////////////
raise(runtime_exception("Testing"));
///////////////////
// bits per pixel
if ( integerp(caddr(p)) )
bits = caddr(p)->integer;
// options
cons_t *opts = symbolp(caddr(p))? cddr(p) :
symbolp(cadddr(p))? cdddr(p) : nil();;
for ( cons_t *s = opts; !nullp(s); s = cdr(s) ) {
assert_type(SYMBOL, car(s));
std::string sym = symbol_name(s);
int size = sizeof(sdl_flags) / sizeof(key_value_t<std::string, uint32_t>);
for ( int n=0; n < size; ++n )
if ( sym == sdl_flags[n].key ) {
///////////////////
printf("flag %s\n", sym.c_str());
printf("value %d and %d\n", sdl_flags[n].value, SDL_HWSURFACE);
///////////////////
mode |= sdl_flags[n].value;
goto NEXT_FLAG;
}
raise(runtime_exception("Unknown SDL video mode flag: " + sym));
NEXT_FLAG:
continue;
}
mode = SDL_HWSURFACE;
///////////////////
printf("video mode\n"); fflush(stdout);
///////////////////
SDL_Surface *screen = SDL_SetVideoMode(x, y, bits, mode);
if ( screen == NULL )
raise(runtime_exception(SDL_GetError()));
return pointer(new pointer_t("sdl-surface", (void*)screen));
}
PARBRE MakeCste(int val) {
PARBRE res;
res = NEW(1, ARBRE);
res->op = Cste; res->gauche.E = val; res->droit.A = nil(ARBRE);
return(res);
}
Expr* Eval(Env* env, Expr* expr, Expr* cont){
if(expr->evaled == 1) {
printf("evaled\n");
return expr;
}
while(expr != NULL){
switch(expr->type){
case Number_Exp :
// puts("in Eval Number");
return expr;
case Symbol_Exp :
// puts("in Eval Symbol");
if(strcmp(expr->u.symbol, "nil") == 0) return nil();
Expr* res = (Expr*)lookup_expr_symbol(env, expr->u.symbol);
// printf("%d", res->u.int_value);
return res;
case Quote_Exp :
return (Expr *)EvalQuote(expr);
return NullList();
case Pair_Exp :
return EvalPair(env, expr, cont);
}
expr = expr->next;
}
}
static Point2D intersec(const Point2D& b1, const Point2D& e1, const Point2D& b2, const Point2D& e2)
{
Point2D result = nil();
Point2D v = e1 - b1;
double n = v.norm();
Point2D u = v / n;
Point2D seg1 = b2 - b1;
Point2D seg2 = e2 - b1;
double cos1 = seg1 * u;
double cos2 = seg2 * u;
double sin1 = seg1 ^ u;
double sin2 = seg2 ^ u;
if(sin1 * sin2 <= 0)
{
double sin = sin1 - sin2;
if(sin)
{
double ratio = (cos2 - cos1) * sin1 / sin; // Congruent Triangles
double scale = cos1 + ratio;
if(0 < scale && scale < n)
{
result = b1 + scale * u;
}
}
}
return result;
}
argument
damp(EXTERNAL_ARG(ls1), EXTERNAL_ARG(ls2), EXTERNAL_ARG(fact))
{
DECLARE_ARG(ls1, float_list *);
DECLARE_ARG(ls2, float_list *);
DECLARE_ARG(fact, float_val);
float_list *ptr1((float_list*)ls1);
float_list *ptr2((float_list*)ls2);
float_list *nil(float_list::null_list());
if(float_list::is_null(ptr1) || float_list::is_null(ptr2)) {
RETURN_ARG(nil);
}
stack_float_list vals;
while(!float_list::is_null(ptr1) && !float_list::is_null(ptr2)) {
const float_val h1(ptr1->get_head());
const float_val h2(ptr2->get_head());
const float_val c(std::log(fact * std::exp(h2) +
(1.0 - fact) * std::exp(h1)));
vals.push(c);
ptr1 = ptr1->get_tail();
ptr2 = ptr2->get_tail();
}
float_list *ptr(from_stack_to_list<stack_float_list,float_list>(vals));
RETURN_ARG(ptr);
}
Value Scope::self() const {
if (m_Self)
return m_Self;
if (m_Function && m_Function->parent_scope())
return m_Function->parent_scope()->self();
return nil();
}
/*
* (initialize) ==> nothing
*/
cons_t* initialize(cons_t*, environment_t*)
{
if ( SDL_Init(SDL_INIT_VIDEO) != 0 )
raise(runtime_exception(SDL_GetError()));
return nil();
}
int main( int argc, char* argv[] )
{
struct list *l = cons(1.5, cons(2.6, cons(3.7, nil())));
high_level_func( print, l);
// printf("%d",argc);
return 0;
}
item base_list(item argl){
if (!is_null(argl)){
return cons(car(argl), base_list(cdr(argl)));
}
else
return nil();
}
PARBRE MakeString(char *var) {
PARBRE res;
res = NEW(1, ARBRE);
res->op = String; res->gauche.S = var; res->droit.A = nil(ARBRE);
return(res);
}
PARBRE MakeId(char *var) {
PARBRE res;
res = NEW(1, ARBRE);
res->op = Id; res->gauche.S = var; res->droit.A = nil(ARBRE);
return(res);
}
bool Project::hasFixed(Fields fields, const Lisp<Fixed> fixed)
{
for (; ! nil(fields); ++fields)
if (isfixed(fixed, *fields))
return true;
return false;
}
/**
* Création d'une Classe
*/
PCLASSE MakeClasse(char *name, char *name_parent, PATT lattributs, PMETH lmethodes) {
PCLASSE res;
PCLASSE lv = definedClasses;
//une classe ne peut héritée de elle même:
if(name_parent != NULL )
if(! strcmp(name, name_parent) || !strcmp("Entier", name_parent) || !strcmp("Chaine", name_parent)){
fprintf(stderr, "Erreur! %s ne peut être une classe parente de la classe %s \n", name_parent, name);
exit(3);
}else{
check_type_declaration(name_parent,NULL);
}
/* On ne peut que déclarer une seule classe ayant le nom name.
*/
while(lv) {
if (! strcmp(name, lv->name)) {
fprintf(stderr, "Erreur! double declaration de Classe: %s\n", name);
exit(3);
}
else lv = lv->suiv;
}
res = NEW(1, CLASSE);
res->name = name;
res->name_parent = name_parent;
res->lattributs = lattributs;
res->lmethodes = lmethodes;
res->suiv = nil(CLASSE);
res->index = classi;
classi++;
store_next(res);
return(res);
}
void Machine::LD()
{
std::shared_ptr<Elem> nil(new Nil);
std::shared_ptr<Elem> result = nil;
stack_t stack;
List *args = nullptr;
Integer *arg1, *arg2;
if (C->empty()) throw Exception("LD", "ArgumentsNotFound");
arg1 = dynamic_cast<Integer*>(&*(C->top()));
if (arg1 == nullptr)
{
args = dynamic_cast<List*>(&*(C->top()));
if (args == nullptr) throw Exception("LD", "InvalideArguments");
arg1 = dynamic_cast<Integer*>(&*(args->get_value().front()));
if (arg1 == nullptr) throw Exception("LD", "InvalideArguments");
arg2 = dynamic_cast<Integer*>(&*(args->get_value().back()));
if (arg2 == nullptr) throw Exception("LD", "InvalideArguments");
}
if (arg1->get_value() < 1) throw Exception("LD", "InvalideArguments");
for (auto i = 0; i < arg1->get_value(); ++i)
{
if (E->empty()) break;
stack.push(E->pop_ret());
}
if (args != nullptr)
{
if (arg2->get_value() < 1) throw Exception("LD", "InvalideArguments");
auto elem_ptr = dynamic_cast<List*>(stack.top()->clone());
if (elem_ptr == nullptr)
{
if (arg2->get_value() == 1)
result = stack.top();
}
else
{
auto elem = elem_ptr->get_value();
for (auto i = 1; i < arg2->get_value(); ++i)
{
if (elem.empty()) break;
elem.pop_front();
}
if (!elem.empty()) result = elem.front();
}
}
else
result = stack.top();
while (!stack.empty())
E->push(stack.pop_ret());
S->push(result);
C->pop();
}
cons_t* proc_import(cons_t* p, environment_t* e)
{
assert_length_min(p, 1);
assert_type(PAIR, car(p));
/*
* Handle all import sets in (import <import set> ...)
*/
for ( ; !nullp(p); p = cdr(p) ) {
environment_t *impenv = import_set(car(p));
/*
* Now we need to bring the imported environment to the environment,
* so that the new definitions are available there.
*
* We do this by copying the definitions.
*/
merge(e, impenv);
/*
* But we also need to connect the lower level imported environment to
* definitions found in its outer environment.
*
* This is because the exported functions in impenv must be able to see
* definitions in the toplevel, controlling, environment.
*
* Consider the (mickey environment) module, which has a "syntactic"
* procedure bound?.
*
* If we (import (scheme write)) then we get the procedure display. But
* if we now (import (mickey environment)) and call (bound? display)
* then bound? will not be able to see any definition of display, and
* will wrongly return #f.
*
* Note that I'm not entirely certain that this is the correct way of
* handling things, since closures must be evaluated in the environment
* they were defined in.
*
* TODO: Think hard about this and write some tests.
*
* Note that this behaviour might be different for libraries that are
* imported as scheme source code. They must be first evaluated in
* their own closed environment (to bind definitions) before being
* connected to the outer one.
*
* I think what we need is a global pointer to the ACTUAL top-level
* environment.
*
*/
impenv->outer = e;
}
/*
* TODO: Should we return the final environment, so we can easily run
* cond-expand on it from outside define-library? E.g., (cond-expand
* (import (foo bar)))
*/
return unspecified(nil());
}
Indexes Project::indexes()
{
Indexes idxs;
for (Indexes src = source->indexes(); ! nil(src); ++src)
if (subset(flds, *src))
idxs.push(*src);
return idxs;
}
PARG MakeArgument(PARBRE expression) {
PARG res;
res = NEW(1, ARGUMENT);
res->expression = expression;
res->suiv = nil(ARGUMENT);
return(res);
}
oyster *builtin_eofp(machine *m){
ARG(c);
char d = (char)oyster_value(c);
if(d == EOF){
return arg("t");
}
return nil();
};
closure *reverse(closure *a){
closure *ret = nil();
while(!nilp(a)){
ret = cons(car(a), ret);
a = cdr(a);
}
return ret;
}
item if_alternative(item exp){
if (!is_null(cdr(cdr(cdr(exp))))){
return car(cdr(cdr(cdr(exp))));
}
else{
return nil();
}
}
