/* -*- mode:c;coding:iso-8859-1 -*- */
/*****************************************************************************
****FILE:               ast.c
****LANGUAGE:           c
****SYSTEM:             POSIX
****USER-INTERFACE:     NONE
****DESCRIPTION
****
****    Dumps the AST obtained from the clang-c parsing library as a
****    S-Exp, that can be easily read by lisp programs.
****
****AUTHORS
****    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
****MODIFICATIONS
****    2013-01-29 <PJB> Created.
****    2013-02-03 <PJB>
****BUGS
****LEGAL
****    AGPL3
****
****    Copyright Pascal J. Bourguignon 2013 - 2013
****
****    This program is free software: you can redistribute it and/or
****    modify it under the terms of the GNU Affero General Public
****    License as published by the Free Software Foundation, either
****    version 3 of the License, or (at your option) any later
****    version.
****
****    This program 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 Affero General Public License for more
****    details.
****
****    You should have received a copy of the GNU Affero General
****    Public License along with this program.  If not, see
****    <http://www.gnu.org/licenses/>.
*****************************************************************************/
#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <iso646.h>
#include <ctype.h>
#include <limits.h>
#include <clang-c/Index.h>

// Viva Greenspun's Tenth Law! (even Q&D).

typedef enum {false=0,true=1} bool;

#define INCF(X) (++(X))
#define DECF(X) (--(X))

#define CONCAT_INTERN(A,B) A##B
#define CONCAT(A,B) CONCAT_INTERN(A,B)

#define PUSH(ELEMENT,LIST_PLACE)                                        \
    ({ (LIST_PLACE)=cons((ELEMENT),(LIST_PLACE)); })

#define POP_INTERN(RESVAR,LIST_PLACE)                                   \
    ({ id RESVAR=car(LIST_PLACE);                                       \
        (LIST_PLACE)=cdr(LIST_PLACE);                                   \
        RESVAR; })

#define POP(LIST_PLACE)                                                 \
    POP_INTERN(CONCAT(ReSuLt_,__LINE__),LIST_PLACE)

#define PUSH2(k,v,plist) ({PUSH(v,plist);PUSH(k,plist);})

#define DOTIMES_INTERNAL(VAR,COUNT_VAR,COUNT,BODY)                      \
    do{                                                                 \
        typeof(COUNT) COUNT_VAR=(COUNT);                                \
        for(typeof(COUNT) VAR=0;VAR<COUNT_VAR;INCF(VAR)){               \
            BODY}                                                       \
    }while(0)
#define DOTIMES(VAR,COUNT,BODY) \
    DOTIMES_INTERNAL(VAR,CONCAT(CoUnT_,__LINE__),COUNT,BODY)

#define DOLIST_INTERNAL(VAR,LIST_VAR,LIST,BODY)                         \
    do{                                                                 \
        id LIST_VAR=(LIST);                                             \
        while(LIST_VAR){                                                \
            do{ id VAR=car(LIST_VAR); BODY }while(0);                   \
            LIST_VAR=cdr(LIST_VAR);}                                    \
    }while(0)
#define DOLIST(VAR,LIST_EXPRESSION,BODY) \
    DOLIST_INTERNAL(VAR,CONCAT(LiSt_,__LINE__),LIST_EXPRESSION,BODY)

#define ONCE_INTERNAL(VAR,BODY) \
    do{                         \
        static int VAR=0;       \
        if(!VAR){               \
            VAR=1;              \
            {BODY}}             \
    }while(0)
#define ONCE(BODY) ONCE_INTERNAL(CONCAT(OnCe_,__LINE__),BODY)



void signal_error(const char* file,int line,const char* function,const char* message,...){
    fprintf(stderr,"\n%s:%d:1: error in %s: ",file,line,function);
    va_list ap;
    va_start(ap,message);
    vfprintf(stderr,message,ap);
    va_end(ap);
    fprintf(stderr,"\n");
    fflush(stderr);}


#define ERROR_INTERNAL(MESSAGE,...)                                         \
    do{                                                                     \
        signal_error(__FILE__,__LINE__,__FUNCTION__,MESSAGE,##__VA_ARGS__); \
        exit(1);}                                                           \
    while(0)
#define ERROR(MESSAGE,...)                                              \
    ERROR_INTERNAL(MESSAGE,##__VA_ARGS__)

#define ASSERT_INTERNAL(EXPRESSION)                                     \
    do{                                                                 \
       if(!(EXPRESSION)){                                               \
           fflush(stdout);                                              \
           signal_error(__FILE__,__LINE__,__FUNCTION__,                 \
                        "assertion failed: %s",#EXPRESSION);            \
           exit(1);}}                                                   \
    while(0)

#define UNLESS_ASSERT_INTERNAL(EXPRESSION,BODY)                         \
    do{                                                                 \
        if(!(EXPRESSION)){                                              \
            fflush(stdout);                                             \
            signal_error(__FILE__,__LINE__,__FUNCTION__,                \
                         "assertion failed: %s",#EXPRESSION);           \
            { BODY }                                                    \
              fflush(stderr);                                           \
              exit(1);}}                                                \
    while(0)


#define assert(EXPRESSION) ASSERT_INTERNAL(EXPRESSION)
#define unless_assert(EXPRESSION,BODY) UNLESS_ASSERT_INTERNAL(EXPRESSION,BODY)
#define ASSERT(EXPRESSION,MESSAGE,...) \
    UNLESS_ASSERT_INTERNAL(EXPRESSION,{fprintf(stderr,MESSAGE,##__VA_ARGS__);})



int imax(int a,int b){
    return((a<b)?b:a);}

int imin(int a,int b){
    return((a<b)?a:b);}


void* memory_allocate(const char* fname,int element_size,int element_count){
    // /*DEBUG*/printf("%s(%s,%d)\n",__FUNCTION__,fname,size); fflush(stdout);
    void* memory=malloc(imax(0,element_size*element_count));
    if(0==memory){
        ERROR("%s: out of memory.",fname);}
    return(memory);}



typedef long long integer_t;
typedef char      character_t;
#define INTEGER_FMT   "%lld"
#define CHARACTER_FMT "%c"

typedef enum {
    ot_nil=0,
    ot_t,
    ot_object=ot_t,
    ot_CXType,            // CXType
    ot_CXToken,           // CXToken
    ot_CXCursor,          // CXCursor
    ot_CXSourceRange,     // CXSourceRange
    ot_CXSourceLocation,  // CXSourceLocation
    ot_CXTranslationUnit, // CXTranslationUnit
    ot_stream,      // FILE*
    ot_int,         // int
    ot_char,        // char
    ot_cons,        // cons_t*
    ot_vector,      // vector_t*
    ot_symbol,      // symbol_t*
    ot_package,     // package_t*
    ot_hashtable,   // hashtable_t*
} object_type;

const char* type_name(object_type type){
switch(type){
  case ot_nil:                 return("nil");
  case ot_t:                   return("t");
  case ot_CXType:              return("CXType");
  case ot_CXToken:             return("CXToken");
  case ot_CXCursor:            return("CXCursor");
  case ot_CXSourceRange:       return("CXSourceRange");
  case ot_CXSourceLocation:    return("CXSourceLocation");
  case ot_CXTranslationUnit:   return("CXTranslationUnit");
  case ot_stream:              return("stream");
  case ot_int:                 return("integer");
  case ot_char:                return("character");
  case ot_cons:                return("cons");
  case ot_vector:              return("vector");
  case ot_symbol:              return("symbol");
  case ot_package:             return("package");
  case ot_hashtable:           return("hashtable");
  default:                     ASSERT(false,"Unknown type %d",type);}}

int type_size(object_type type){
switch(type){
  case ot_nil:                 return(0);
  case ot_t:                   return(sizeof(struct object*));
  case ot_CXType:              return(sizeof(CXType));
  case ot_CXToken:             return(sizeof(CXToken));
  case ot_CXCursor:            return(sizeof(CXCursor));
  case ot_CXSourceRange:       return(sizeof(CXSourceRange));
  case ot_CXSourceLocation:    return(sizeof(CXSourceLocation));
  case ot_CXTranslationUnit:   return(sizeof(CXTranslationUnit));
  case ot_stream:              return(sizeof(FILE*));
  case ot_int:                 return(sizeof(integer_t));
  case ot_char:                return(sizeof(character_t));
  case ot_cons:                return(sizeof(struct cons*));
  case ot_vector:              return(sizeof(struct vector*));
  case ot_symbol:              return(sizeof(struct symbol*));
  case ot_package:             return(sizeof(struct package*));
  case ot_hashtable:           return(sizeof(struct hashtable*));
  default:                     ASSERT(false,"Unknown type %d",type);}}





typedef struct object {
    object_type type;
    union {
        CXType type;
        CXToken token;
        CXCursor cursor;
        CXSourceRange range;
        CXSourceLocation location;
        CXTranslationUnit translation_unit;
        integer_t integer;
        character_t character;
        FILE* stream;
        struct cons* cons;
        struct vector* vector;
        struct symbol* symbol;
        struct package* package;
        struct hashtable* hashtable;
    } value;
} object;

typedef object* id;

id string(const char*);
id intern(id name,id pack);
#define KW(NAME) (intern(string(#NAME),keyword))
#define SY(NAME) (intern(string(#NAME),package))



id standard_input=0;
id standard_output=0;
id error_output=0;
id trace_output=0;
id objects_being_printed=0;
id print_circle=0;
id all_packages=0; // list all packages
id user=0;    // user package
id keyword=0; // keyword package
id package=0; // current package

id prin1(id object,id stream);



void* nil=0;

bool null(void* object){
    return(0==object);}

static object t_object={ot_t};
id t=&t_object; // temporarily. It's replaced my SY(t) in initialize.

id boolean(int value){
    return(value?t:nil);}


object_type type_of(id object){
    if(null(object)){
        return(ot_nil);}
    else{
        return(object->type);}}

id box(object_type type,...){
    id o=memory_allocate(__FUNCTION__,sizeof(*o),1);
    o->type=type;
    va_list ap;
    va_start(ap,type);
    switch(type){
      case ot_CXType:            o->value.type=(va_arg(ap,CXType));                 break;
      case ot_CXToken:           o->value.token=(va_arg(ap,CXToken));               break;
      case ot_CXCursor:          o->value.cursor=(va_arg(ap,CXCursor));             break;
      case ot_CXSourceRange:     o->value.range=(va_arg(ap,CXSourceRange));         break;
      case ot_CXSourceLocation:  o->value.location=(va_arg(ap,CXSourceLocation));   break;
      case ot_CXTranslationUnit: o->value.translation_unit=(va_arg(ap,CXTranslationUnit)); break;
      case ot_stream:            o->value.stream=(va_arg(ap,FILE*));                break;
      case ot_int:               o->value.integer=va_arg(ap,integer_t);             break;
      case ot_char:              o->value.character=va_arg(ap,int);                 break;
      case ot_cons:              o->value.cons=va_arg(ap,struct cons*);             break;
      case ot_vector:            o->value.vector=va_arg(ap,struct vector*);         break;
      case ot_symbol:            o->value.symbol=va_arg(ap,struct symbol*);         break;
      case ot_package:           o->value.package=va_arg(ap,struct package*);       break;
      case ot_hashtable:         o->value.hashtable=va_arg(ap,struct hashtable*);   break;
      default: ERROR("unexpected object type %s.",type_name(type));         break;}
    va_end(ap);
    return(o);}



#define DEFINE_BASE_FUNCTIONS(LISP_NAME,CXTYPE,OT_CXTYPE)               \
    id LISP_NAME##p(id x){                                              \
        return(boolean(not(null(x)) and (OT_CXTYPE==type_of(x))));}     \
    id LISP_NAME(CXTYPE value){                                         \
        return(box(OT_CXTYPE,value));}                                  \
    CXTYPE unbox_##LISP_NAME(id o){                                     \
        assert(nil!=o);                                                 \
        assert(OT_CXTYPE==type_of(o));                                  \
        return(o->value.LISP_NAME);}                                    \
    extern int errno

DEFINE_BASE_FUNCTIONS(type,CXType,ot_CXType);
DEFINE_BASE_FUNCTIONS(token,CXToken,ot_CXToken);
DEFINE_BASE_FUNCTIONS(cursor,CXCursor,ot_CXCursor);
DEFINE_BASE_FUNCTIONS(range,CXSourceRange,ot_CXSourceRange);
DEFINE_BASE_FUNCTIONS(location,CXSourceLocation,ot_CXSourceLocation);
DEFINE_BASE_FUNCTIONS(translation_unit,CXTranslationUnit,ot_CXTranslationUnit);

DEFINE_BASE_FUNCTIONS(stream,FILE*,ot_stream);
DEFINE_BASE_FUNCTIONS(integer,integer_t,ot_int);
DEFINE_BASE_FUNCTIONS(character,character_t,ot_char);


id zerop(id object){
    return(boolean(integerp(object) and (0==unbox_integer(object))));}

id plusp(id object){
    return(boolean(integerp(object) and (0<unbox_integer(object))));}

id minusp(id object){
    return(boolean(integerp(object) and (0>unbox_integer(object))));}



typedef struct cons {
    id car;
    id cdr;
} cons_t;

cons_t* make_cons_t(id a,id d){
    cons_t* cell=memory_allocate(__FUNCTION__,sizeof(*cell),1);
    cell->car=a;
    cell->cdr=d;
    return(cell);}

id consp(id a){
    return(boolean(not(null(a)) and (ot_cons==type_of(a))));}

cons_t* unbox_cons(id o){
    assert(nil!=o);
    assert(ot_cons==type_of(o));
    return(o->value.cons);}

id cons(id a,id d){
    return(box(ot_cons,make_cons_t(a,d)));}

id car(id cell){
    if(null(cell)){ return(cell); }
    else if(ot_cons==type_of(cell)){ return(cell->value.cons->car); }
    else{ ERROR("Expected argument of type LIST, not %s",
                type_name(type_of(cell))); return(nil); }}

id cdr(id cell){
    if(null(cell)){ return(cell); }
    else if(ot_cons==type_of(cell)){ return(cell->value.cons->cdr); }
    else{ ERROR("Expected argument of type LIST, not %s",
                type_name(type_of(cell))); return(nil); }}

id setcar(id cell,id a){
    if(cell and (ot_cons==type_of(cell))){ cell->value.cons->car=a; return(a); }
    else{ ERROR("Expected argument of type CONS, not %s",
                type_name(type_of(cell))); return(nil); }}

id setcdr(id cell,id d){
    if(cell and (ot_cons==type_of(cell))){ cell->value.cons->cdr=d; return(d); }
    else{ ERROR("Expected argument of type CONS, not %s",
                type_name(type_of(cell))); return(nil); }}

id caar   (id cell){return(car(car(cell)));}
id cadr   (id cell){return(car(cdr(cell)));}
id cdar   (id cell){return(cdr(car(cell)));}
id cddr   (id cell){return(cdr(cdr(cell)));}

id caaar  (id cell){return(car(car(car(cell))));}
id cadar  (id cell){return(car(cdr(car(cell))));}
id cdaar  (id cell){return(cdr(car(car(cell))));}
id cddar  (id cell){return(cdr(cdr(car(cell))));}

id caadr  (id cell){return(car(car(cdr(cell))));}
id caddr  (id cell){return(car(cdr(cdr(cell))));}
id cdadr  (id cell){return(cdr(car(cdr(cell))));}
id cdddr  (id cell){return(cdr(cdr(cdr(cell))));}

id first  (id list){return(car(list));}
id rest   (id list){return(cdr(list));}
id second (id list){return(car(cdr(list)));}
id third  (id list){return(car(cdr(cdr(list))));}
id fourth (id list){return(car(cdr(cdr(cdr(list)))));}
id fifth  (id list){return(car(cdr(cdr(cdr(cdr(list))))));}
id sixth  (id list){return(car(cdr(cdr(cdr(cdr(cdr(list)))))));}
id seventh(id list){return(car(cdr(cdr(cdr(cdr(cdr(cdr(list))))))));}
id eighth (id list){return(car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(list)))))))));}
id nineth (id list){return(car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(list))))))))));}
id tenth  (id list){return(car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(list)))))))))));}

id last   (id list){
    while(cdr(list)){
        list=cdr(list);}
    return(list);}

id nth(int n,id list){
    while((0<n--) and list){
        list=cdr(list);}
    return(car(list));}

id nthcdr(int n,id list){
    while((0<--n) and list){
        list=cdr(list);}
    return(list);}


int list_length(id list){
    int n=0;
    while(consp(list)){
        list=cdr(list);
        INCF(n);}
    return(n);}

id list(int n,...){
    switch(n){
      case 0:
          return(nil);
      default:{
          va_list ap;
          va_start(ap,n);
          id result=cons(va_arg(ap,id),nil);
          id tail=result;
          for(int i=1;i<n;INCF(i)){
              setcdr(tail,cons(va_arg(ap,id),nil));
              tail=cdr(tail);}
          va_end(ap);
          return(result);}}}

id prepend(int n,...){
    // list*
    switch(n){
      case 0:
          return(nil);
      case 1:{
          va_list ap;
          va_start(ap,n);
          id result=va_arg(ap,id);
          va_end(ap);
          return(result);}
      default:{
          va_list ap;
          va_start(ap,n);
          id result=cons(va_arg(ap,id),nil);
          id tail=result;
          for(int i=2;i<n;INCF(i)){
              setcdr(tail,cons(va_arg(ap,id),nil));
              tail=cdr(tail);}
          va_end(ap);
          setcdr(tail,va_arg(ap,id));
          return(result);}}}

id reverse_accumulator(id list,id reversed){
    return(null(list)
           ?reversed
           :reverse_accumulator(cdr(list),cons(car(list),reversed)));}

id reverse(id list){
    return(reverse_accumulator(list,nil));}

id revappend(id list,id tail){
    return(reverse_accumulator(list,tail));}

id nreconc(id list,id tail){
    while(not(null(list))){
        id next=cdr(list);
        setcdr(list,tail);
        tail=list;
        list=next;}
    return(tail);}

id nreverse(id list){
    return(nreconc(list,nil));}

id copy_list(id list){
    if(null(list)){
        return(nil);}
    else{
        id result=cons(car(list),nil);
        id tail=result;
        list=cdr(list);
        while(not(null(list))){
            setcdr(tail,cons(car(list),nil));
            tail=cdr(tail);
            list=cdr(list);}
        return(result);}}

id append(int n,...){
    switch(n){
      case 0: return(nil);
      case 1:{
          va_list ap;
          va_start(ap,n);
          id result=va_arg(ap,id);
          va_end(ap);
          return(result);}
      default:{
          va_list ap;
          va_start(ap,n);
          id result=cons(nil,nil);
          id tail=result;
          for(int i=1;i<n;INCF(i)){
              setcdr(tail,copy_list(va_arg(ap,id)));
              tail=last(tail);}
          setcdr(tail,va_arg(ap,id));
          va_end(ap);
          return(cdr(result));}}}

id nconc(int n,...){
    switch(n){
      case 0: return(nil);
      case 1:{
          va_list ap;
          va_start(ap,n);
          id result=va_arg(ap,id);
          va_end(ap);
          return(result);}
      default:{
          va_list ap;
          va_start(ap,n);
          id result=cons(nil,nil);
          id tail=result;
          for(int i=1;i<n;INCF(i)){
              setcdr(tail,va_arg(ap,id));
              tail=last(tail);}
          setcdr(tail,va_arg(ap,id));
          va_end(ap);
          return(cdr(result));}}}



typedef struct vector {
    object_type element_type;
    int size;
    int fill_pointer;
    char* data;
} vector_t;

id vectorp(id x){
    return(boolean(not(null(x)) and (ot_vector==type_of(x))));}

vector_t* unbox_vector(id o){
    assert(nil!=o);
    assert(ot_vector==type_of(o));
    return(o->value.vector);}

vector_t* vector_set_data(vector_t* v,int index,const void* data);

id make_vector(object_type element_type,int size,int fill_pointer,const void* initial_element){
    int element_size=type_size(element_type);
    assert(0<element_size);
    assert(0<=size);
    assert(0<=fill_pointer);
    assert(fill_pointer<=size);
    vector_t* v=memory_allocate(__FUNCTION__,sizeof(*v),1);
    v->data=memory_allocate(__FUNCTION__,element_size,size);
    v->element_type=element_type;
    v->size=size;
    v->fill_pointer=fill_pointer;
    if(0!=initial_element){
        DOTIMES(i,size,{vector_set_data(v,i,initial_element);});}
    return(box(ot_vector,v));}

object_type vector_element_type(id vect){
    vector_t* v=unbox_vector(vect);
    return(v->element_type);}

int vector_size(id vect){
    vector_t* v=unbox_vector(vect);
    return(v->size);}

int vector_fill_pointer(id vect){
    vector_t* v=unbox_vector(vect);
    return(v->fill_pointer);}

id vector_set_fill_pointer(id vect,int fill_pointer){
    vector_t* v=unbox_vector(vect);
    assert(0<=fill_pointer);
    assert(fill_pointer<=v->size);
    v->fill_pointer=fill_pointer;
    return(vect);}

int vector_length(id vect){
    return(vector_fill_pointer(vect));}


vector_t* vector_set_data(vector_t* v,int index,const void* data){
    assert(nil!=v);
    assert(0<=index);
    assert(index<v->size);
    int element_size=type_size(v->element_type);
    char* slot=v->data+element_size*index;
    memcpy(slot,data,element_size);
    return(v);}

id vector_set_char(id vect,int index,character_t data){
    vector_t* v=unbox_vector(vect);
    assert(ot_char==v->element_type);
    vector_set_data(v,index,&data);
    return(vect);}

id vector_set_int(id vect,int index,integer_t data){
    vector_t* v=unbox_vector(vect);
    assert(ot_int==v->element_type);
    vector_set_data(v,index,&data);
    return(vect);}

id vector_set(id vect,int index,id object){
    vector_t* v=unbox_vector(vect);
    switch(v->element_type){
      case ot_t:
          vector_set_data(v,index,&object);
          break;
      case ot_int:
          if(ot_int==type_of(object)){
              integer_t value=unbox_integer(object);
              vector_set_data(v,index,&value);}
          else{
              ERROR("Trying to store a non-integer into a (VECTOR INTEGER).");}
          break;
      case ot_char:
          if(ot_char==type_of(object)){
              character_t value=unbox_character(object);
              vector_set_data(v,index,&value);}
          else{
              ERROR("Trying to store a non-character into a STRING.");}
          break;
      default:
          ERROR("Unexpected vector element type %s.",type_name(v->element_type));
          break;}
    return(vect);}

id vector(int n,...){
    switch(n){
      case 0:
          return(make_vector(ot_t,0,0,0));
      default:{
          id v=make_vector(ot_t,n,n,0);
          va_list ap;
          va_start(ap,n);
          DOTIMES(i,n,{vector_set(v,i,va_arg(ap,id));});
          va_end(ap);
          return(v);}}}

void* vector_get_data(vector_t* v,int index){
    assert(nil!=v);
    assert(0<=index);
    assert(index<v->size);
    return(v->data+type_size(v->element_type)*index);}

character_t vector_get_char(id vect,int index){
    vector_t* v=unbox_vector(vect);
    assert(ot_char==v->element_type);
    character_t result;
    memcpy(&result,vector_get_data(v,index),sizeof(character_t));
    return(result);}

integer_t vector_get_int(id vect,int index){
    vector_t* v=unbox_vector(vect);
    assert(ot_int==v->element_type);
    integer_t result;
    memcpy(&result,vector_get_data(v,index),sizeof(integer_t));
    return(result);}

id vector_get(id vect,int index){
    vector_t* v=unbox_vector(vect);
    id result=0;
    switch(v->element_type){
      case ot_t:
          memcpy(&result,vector_get_data(v,index),type_size(ot_t));
          break;
      case ot_int:
          result=integer(*(integer_t*)vector_get_data(v,index));
          break;
      case ot_char:
          result=character(*(character_t*)vector_get_data(v,index));
          break;
      default:
          ERROR("Unexpected vector element type %s.",type_name(v->element_type));
          break;}
    return(result);}


id stringp(id x){
    return(boolean(not(null(x))
                   and (ot_vector==type_of(x))
                   and (ot_char==vector_element_type(x))));}

id string(const char* text){
    int len=strlen(text);
    id vect=make_vector(ot_char,1+len,len,0);
    strcpy(vect->value.vector->data,text);
    return(vect);}

const char* unbox_string(id string){
    assert(stringp(string));
    return(vector_get_data(unbox_vector(string),0));}

bool string_equal(vector_t* a,vector_t* b){
    if((a->element_type!=b->element_type)
       or (ot_char!=a->element_type)
       or (a->fill_pointer!=b->fill_pointer)){
        return(false);}
    return(0==memcmp(a->data,b->data,a->fill_pointer));}

unsigned string_hash(id string){
    assert(stringp(string));
    vector_t* s=unbox_vector(string);
    // djb2 (k=33)
    assert(nil!=s);
    assert(ot_char==s->element_type);
    int count=s->fill_pointer;
    const char* bytes=s->data;
    unsigned hash=5381;
    int c;
    while((c=*bytes++)){
        hash=((hash<<5)+hash)^c;}
    return(hash);}


int length(id object){
    if(null(object)){
        return(0);}
    else if(consp(object)){
        return(list_length(object));}
    else if(vectorp(object)){
        return(vector_length(object));}
    else{
        ERROR("Expected object of type SEQUENCE, not %s.",type_name(type_of(object)));
        return(0);}}


id equal(id a,id b){
    if(a==b){
        return(t);}
    else if(null(a) or null(b)){
        return(nil);}
    else if(a->type==b->type){
        switch(a->type){
          case ot_nil:                return(t);
          case ot_CXType:             return(boolean(clang_equalTypes(a->value.type,b->value.type)));
          case ot_CXToken:            return(boolean((a->value.token.int_data[1]==b->value.token.int_data[1])
                                                     and (a->value.token.int_data[2]==b->value.token.int_data[2])));
          case ot_CXCursor:           return(boolean(clang_equalCursors(a->value.cursor,b->value.cursor)));
          case ot_CXSourceRange:      return(boolean(clang_equalRanges(a->value.range,b->value.range)));
          case ot_CXSourceLocation:   return(boolean(clang_equalLocations(a->value.location,b->value.location)));
          case ot_CXTranslationUnit:  return(boolean(a->value.translation_unit==b->value.translation_unit));
          case ot_int:                return(boolean(a->value.integer==b->value.integer));
          case ot_char:               return(boolean(a->value.character==b->value.character));
          case ot_cons:               return(boolean(equal(car(a),car(b)) and equal(cdr(a),cdr(b))));
          case ot_vector:             return(boolean((a->value.vector==b->value.vector)
                                                     or ((ot_char==a->value.vector->element_type)
                                                         and (ot_char==b->value.vector->element_type)
                                                         and string_equal(a->value.vector,b->value.vector))));
          case ot_symbol:             return(boolean(a->value.symbol==b->value.symbol));
          case ot_package:            return(boolean(a->value.package==b->value.package));
          case ot_hashtable:          return(boolean(a->value.hashtable==b->value.hashtable));
          default: assert(!"Unexpected type in an object."); return(nil); }}
    else{
        return(nil);}}



id acons(id key,id value,id alist){
    return(cons(cons(key,value),alist));}

id assoc(id key,id alist){
    while(not(null(alist)) and not(equal(key,caar(alist)))){
        alist=cdr(alist);}
    if(null(alist)){
        return(nil);}
    else{
        return(car(alist));}}

#define APUSH(KEY,VALUE,ALIST_VAR) do{ ALIST_VAR=acons(KEY,VALUE,ALIST_VAR); }while(0)



typedef struct hashtable {
    int count;
    int size;
    float rehash_size;
    float rehash_threshold;
    id* entries;
} hashtable_t;

id hashtablep(id x){
    return(boolean(not(null(x)) and (ot_hashtable==type_of(x))));}

hashtable_t* unbox_hashtable(id o){
    assert(nil!=o);
    assert(ot_hashtable==type_of(o));
    return(o->value.hashtable);}

int hashtable_count(id table){
    hashtable_t* h=unbox_hashtable(table);
    return(h->count);}

int hashtable_size(id table){
    hashtable_t* h=unbox_hashtable(table);
    return(h->size);}

float hashtable_rehash_size(id table){
    hashtable_t* h=unbox_hashtable(table);
    return(h->rehash_size);}

float hashtable_rehash_threshold(id table){
    hashtable_t* h=unbox_hashtable(table);
    return(h->rehash_threshold);}

unsigned hashtable_hash(hashtable_t*);
id symbol_name(id symbol);

unsigned sxhash(id o){
    switch(type_of(o)){
      case ot_nil:                return(0);
      case ot_t:                  assert(!"Invalid object"); return(0);
      case ot_CXType:             return(((unsigned)(o->value.type.data[0]))
                                         ^(((unsigned)(o->value.type.data[1]))<<5));
      case ot_CXToken:            return(((unsigned)(o->value.token.int_data[1]))
                                         ^(((unsigned)(o->value.token.int_data[2]))<<5));
      case ot_CXCursor:           return(clang_hashCursor(o->value.cursor));
      case ot_CXSourceRange:      return(o->value.range.begin_int_data
                                         ^(o->value.range.end_int_data<<9)
                                         ^((unsigned)(o->value.range.ptr_data[0])<<1)
                                         ^((unsigned)(o->value.range.ptr_data[1])<<5));
      case ot_CXSourceLocation:   return(o->value.location.int_data
                                         ^((unsigned)(o->value.location.ptr_data[0])<<1)
                                         ^((unsigned)(o->value.location.ptr_data[1])<<5));
      case ot_CXTranslationUnit:  return((unsigned)(o->value.translation_unit));
      case ot_stream:             return((unsigned)(o->value.stream));
      case ot_int:                return(o->value.integer);
      case ot_char:               return(o->value.character);
      case ot_cons:               return(sxhash(car(o))^(sxhash(cdr(o))<<1));
      case ot_symbol:             return(string_hash(symbol_name(o)));
      case ot_vector:             return((ot_char==o->value.vector->element_type)
                                         ?string_hash(o)
                                         :(unsigned)(o->value.vector));
      case ot_package:            return((unsigned)(o->value.package));
      case ot_hashtable:          return((unsigned)(o->value.hashtable));}
    return(0);}


int ceiling_to_nearest_prime(int n);
bool primep(int n);

id hashtable_deleted_entry=0;
bool hashtable_entry_deleted_p(id entry){
    return(hashtable_deleted_entry==entry);}

id make_hashtable(int size){
    if(null(hashtable_deleted_entry)){
        hashtable_deleted_entry=cons(string("deleted"),nil);}
    hashtable_t* h=memory_allocate(__FUNCTION__,sizeof(*h),1);
    h->count=0;
    h->size=primep(size)?size:ceiling_to_nearest_prime(1+size);
    h->rehash_size=2.0;
    h->rehash_threshold=1.5;
    h->entries=memory_allocate(__FUNCTION__,sizeof(*(h->entries)),h->size);
    DOTIMES(i,h->size,{h->entries[i]=nil;});
    return(box(ot_hashtable,h));}

unsigned hashtable_hash(hashtable_t* table){
    return((table->size<<3)+table->count);}

id hashtable_get(id table,id key){
    hashtable_t* h=unbox_hashtable(table);
    unsigned hash=sxhash(key);
    int i=hash%h->size;
    while(not(null(h->entries[i]))
          and not(equal(car(h->entries[i]),key))){
        i=(i+1)%h->size;}
    return(cdr(h->entries[i]));}

id hashtable_clear(id table){
    hashtable_t* h=unbox_hashtable(table);
    h->count=0;
    memset(h->entries,0,sizeof(h->entries[0])*h->size);
    return(table);}

id hashtable_remove(id table,id key){
    hashtable_t* h=unbox_hashtable(table);
    unsigned hash=sxhash(key);
    int i=hash%h->size;
    while(not(null(h->entries[i]))
          and not(equal(car(h->entries[i]),key))){
        i=(i+1)%h->size;}
    id entry=h->entries[i];
    if(equal(car(entry),key)){
        DECF(h->count);
        h->entries[i]=hashtable_deleted_entry;
        return(cdr(entry));}
    else{
        return(nil);}}

typedef void(*hashtable_mapper_function)(id key,id value,void* data);

void hashtable_map(id table,hashtable_mapper_function fun,void* data){
    hashtable_t* h=unbox_hashtable(table);
    int size=h->size;
    id* entries=h->entries;
    DOTIMES(i,size,
            { id entry=entries[i];
              if(not(null(entry) or hashtable_entry_deleted_p(entry))){
                  fun(car(entry),cdr(entry),data);}});}


#define HASH_TRACE(BODY)

id hashtable_statistics(id table){
    hashtable_t* h=unbox_hashtable(table);
    int runs=0;
    int count_nil=0;
    int count_deleted=0;
    int count_used=0;
    int start_used=0;
    int start_deleted=0;
    int run_size_min=INT_MAX;
    int run_size_max=0;
    int deleted_size_min=INT_MAX;
    int deleted_size_max=0;
    int nil_after_deleted=0;
    int deleted_after_nil=0;
    id* entries=h->entries;
    enum {state_nil,state_deleted_in_nil,state_deleted_in_used,state_used} state=state_nil;
    HASH_TRACE({printf("\n");});
    for(int i=0;i<h->size;INCF(i)){
        id entry=h->entries[i];
        if(null(entry)){
            HASH_TRACE({printf("_");});
            INCF(count_nil);}
        else if(hashtable_entry_deleted_p(entry)){
            HASH_TRACE({printf("x");});
            INCF(count_deleted);}
        else{
            HASH_TRACE({printf("U");});
            INCF(count_used);}
        switch(state){
          case state_nil:
              if(null(entry)){
                  /*no change*/}
              else if(hashtable_entry_deleted_p(entry)){
                  if((0!=i) or null(h->entries[h->size-1])){
                      INCF(deleted_after_nil);}
                  start_deleted=i;
                  state=state_deleted_in_nil;}
              else{
                  INCF(runs);
                  start_used=i;
                  state=state_used;}
              break;
          case state_deleted_in_nil:
              if(null(entry)){
                  INCF(nil_after_deleted);
                  int currun=i-start_deleted;
                  deleted_size_min=imin(deleted_size_min,currun);
                  deleted_size_max=imax(deleted_size_max,currun);
                  state=state_nil;}
              else if(hashtable_entry_deleted_p(entry)){
                  /*no change*/}
              else{
                  INCF(runs);
                  int currun=i-start_deleted;
                  deleted_size_min=imin(deleted_size_min,currun);
                  deleted_size_max=imax(deleted_size_max,currun);
                  start_used=i;
                  state=state_used;}
              break;
          case state_deleted_in_used:
              if(null(entry)){
                  INCF(nil_after_deleted);
                  int currun=i-start_deleted;
                  deleted_size_min=imin(deleted_size_min,currun);
                  deleted_size_max=imax(deleted_size_max,currun);
                  currun=i-start_used;
                  run_size_min=imin(run_size_min,currun);
                  run_size_max=imax(run_size_max,currun);
                  state=state_nil;}
              else if(hashtable_entry_deleted_p(entry)){
                  /*no change*/}
              else{
                  int currun=i-start_deleted;
                  deleted_size_min=imin(deleted_size_min,currun);
                  deleted_size_max=imax(deleted_size_max,currun);
                  state=state_used;}
              break;
          case state_used:
              if(null(entry)){
                  int currun=i-start_used;
                  run_size_min=imin(run_size_min,currun);
                  run_size_max=imax(run_size_max,currun);
                  HASH_TRACE({printf("(%d,%d)",run_size_min,run_size_max);});
                  state=state_nil;}
              else if(hashtable_entry_deleted_p(entry)){
                  start_deleted=i;
                  state=state_deleted_in_used;}
              else{
                  /*no change*/}
              break;}}
    switch(state){
      case state_nil:
          break;
      case state_deleted_in_nil:
          break;
      case state_deleted_in_used:{
          INCF(nil_after_deleted);
          int currun=h->size-start_deleted;
          deleted_size_min=imin(deleted_size_min,currun);
          deleted_size_max=imax(deleted_size_max,currun);
          currun=h->size-start_used;
          run_size_min=imin(run_size_min,currun);
          run_size_max=imax(run_size_max,currun);
          state=state_nil;
          break;}
      case state_used:{
          int currun=h->size-start_used;
          run_size_min=imin(run_size_min,currun);
          run_size_max=imax(run_size_max,currun);
          HASH_TRACE({printf("(%d,%d)",run_size_min,run_size_max);});
          break;}}
    HASH_TRACE({printf("\n"); fflush(stdout);});
    return(list(20,
                KW(runs),integer(runs),
                KW(count-nil),integer(count_nil),
                KW(count-deleted),integer(count_deleted),
                KW(count-used),integer(count_used),
                KW(run-size-min),integer(run_size_min),
                KW(run-size-max),integer(run_size_max),
                KW(deleted-size-min),integer(deleted_size_min),
                KW(deleted-size-max),integer(deleted_size_max),
                KW(nil-after-deleted),integer(nil_after_deleted),
                KW(deleted-after-nil),integer(deleted_after_nil)));}

hashtable_t* hashtable_grow(hashtable_t* h){
    int newsize=ceiling_to_nearest_prime(h->size*h->rehash_threshold);
    id* newentries=memory_allocate(__FUNCTION__,sizeof(id),newsize);
    for(int j=0;j<newsize;INCF(j)){
        newentries[j]=nil;}
    for(int i=0;i<h->size;INCF(i)){
        id entry=h->entries[i];
        if(not(null(entry) or hashtable_entry_deleted_p(entry))){
            unsigned hash=sxhash(car(entry));
            int j=hash%newsize;
            while(not(null(newentries[j]))){
                j=(j+1)%newsize;}
            newentries[j]=entry;}}
    h->size=newsize;
    h->entries=newentries;
    return(h);}

id hashtable_set(id table,id key,id value){
    hashtable_t* h=unbox_hashtable(table);
    unsigned hash=sxhash(key);
    int i=hash%h->size;
    while(not(null(h->entries[i]))
          and not(equal(car(h->entries[i]),key))){
        i=(i+1)%h->size;}
    id entry=h->entries[i];
    if(null(entry) or hashtable_entry_deleted_p(entry)){
        if(h->size<=h->count*h->rehash_size){
            hashtable_grow(h);
            // /*DEBUG*/ prin1(hashtable_statistics(table),trace_output);
            return(hashtable_set(table,key,value));}
        else{
            INCF(h->count);
            h->entries[i]=cons(key,value);}}
    else{
        setcdr(entry,value);}
    return(value);}


id compute_primes_to(int n){
    // /*DEBUG*/printf("%s(%d)\n",__FUNCTION__,n); fflush(stdout);
    const int zero=0;
    if(n<2){
        return(make_vector(ot_int,0,0,&zero));}
    else if(2==n){
        id primes=make_vector(ot_int,1,1,&zero);
        vector_set_int(primes,0,2);
        return(primes);}
    else if(3==n){
        id primes=make_vector(ot_int,2,2,&zero);
        vector_set_int(primes,0,2);
        vector_set_int(primes,1,3);
        return(primes);}
    else{
        int bits_max;
        int words_max;
        int word_size=8*sizeof(int);
        int* bits;
        int bit;
        int prime_count=2;
        int cur_prime=3;
        n-=(n%1)?3:2;
        bits_max=n/2;
        words_max=(bits_max+word_size-1)/word_size;
        bits=memory_allocate(__FUNCTION__,sizeof(int),words_max);
        for(int i=0;i<words_max;INCF(i)){
            bits[i]=(~0);}
        while(cur_prime<n){
            bit=cur_prime+(cur_prime-3)/2;
            while(bit<bits_max){
                bits[bit/word_size]&=(~(1<<bit%word_size));
                bit+=cur_prime;}
            bit=1+((cur_prime-3)/2);
            int pos=bit;
            while((pos<=bits_max) and (0==(bits[pos/word_size]&(1<<pos%word_size)))){
                INCF(pos); }
            bit=pos;
            if(bit<bits_max){
                cur_prime=bit+bit+3;
                INCF(prime_count);}
            else{
                cur_prime=n;}}
        // /*DEBUG*/printf("%s(%d) prime_count=%d\n",__FUNCTION__,n,prime_count); fflush(stdout);
        id primes=make_vector(ot_int,(1+prime_count),0,&zero);
        vector_set_fill_pointer(primes,1);
        vector_set_int(primes,0,prime_count);
        int curnum=0;
        vector_set_fill_pointer(primes,1+curnum);
        vector_set_int(primes,curnum++,2);
        vector_set_fill_pointer(primes,1+curnum);
        vector_set_int(primes,curnum++,3);
        bit=1;
        while((bit<=bits_max) and (0==(bits[bit/word_size]&(1<<bit%word_size)))){
            INCF(bit); }
        while((curnum<=prime_count) and (bit<bits_max)){
            cur_prime=bit+bit+3;
            vector_set_fill_pointer(primes,1+curnum);
            vector_set_int(primes,curnum++,cur_prime);
            // /*DEBUG*/printf("%s(%d) prime=%d\n",__FUNCTION__,n,cur_prime); fflush(stdout);
            INCF(bit);
            while((bit<=bits_max) and (0==(bits[bit/word_size]&(1<<bit%word_size)))){
                INCF(bit); }}
        // /*DEBUG*/printf("%s(%d) exit\n",__FUNCTION__,n); fflush(stdout);
        return(primes);}}



id primes=0;

int search_prime(int n,int* order){
    if((nil==primes) or (vector_get_int(primes,vector_length(primes)-1)<n)){
        primes=compute_primes_to(n*2);}
    /*
    +-------------------+----------+-------+----------+----------------+
    | Case              |  found   | index |  order   |     Error      |
    +-------------------+----------+-------+----------+----------------+
    | x < a[i]          |   FALSE  |  min  |  less    |      0         |
    | a[i] < x < a[i+1] |   FALSE  |   i   |  greater |      0         |
    | x = a[i]          |   TRUE   |   i   |  equal   |      0         |
    | a[max] < x        |   FALSE  |  max  |  greater |      0         |
    +-------------------+----------+-------+----------+----------------+
    */
    int min=0;
    int max=vector_length(primes)-1;
    int ind=(min+max)/2;
    int cur=vector_get_int(primes,ind);
    int ord=(n==cur)?0:(n<cur)?-1:1;
    while((0!=ord) and (min!=ind)){
        if(ord<0){
            max=ind;}
        else{
            min=ind;}
        ind=(min+max)/2;
        cur=vector_get_int(primes,ind);
        ord=(n==cur)?0:(n<cur)?-1:1;}
    if((1<ind)and(ord<0)){
        ord=1;
        ind--;}
    (*order)=ord;
    return(ind);}

bool primep(int n){
    int ord=0;
    search_prime(n,&ord);
    return(ord==0);}

int ceiling_to_nearest_prime(int n){
    int ord=0;
    int ind=search_prime(n,&ord);
    if(ord<0){
        return(vector_get_int(primes,1));}
    else{
        return(vector_get_int(primes,1+ind));}}


typedef struct symbol {
    id name;
    id value;
    id function;
    id plist;
    id package;
} symbol_t;

id make_symbol(id name,id package){
    symbol_t* sym=memory_allocate(__FUNCTION__,sizeof(*sym),1);
    sym->name=name;
    sym->package=package;
    sym->value=nil;
    sym->function=nil;
    sym->plist=nil;
    return(box(ot_symbol,sym));}

id symbolp(id object){
    return(boolean(null(object) or (ot_symbol==type_of(object))));}


symbol_t* unbox_symbol(id object){
    assert(symbolp(object));
    if(null(object)){
        object=SY(nil);}
    return(object->value.symbol);}

id symbol_name(id symbol){
    assert(symbolp(symbol));
    symbol_t* s=unbox_symbol(symbol);
    return(s->name);}

id symbol_package(id symbol){
    assert(symbolp(symbol));
    symbol_t* s=unbox_symbol(symbol);
    return(s->package);}

id symbol_value(id symbol){
    assert(symbolp(symbol));
    symbol_t* s=unbox_symbol(symbol);
    return(s->value);}

id symbol_function(id symbol){
    assert(symbolp(symbol));
    symbol_t* s=unbox_symbol(symbol);
    return(s->function);}

id symbol_plist(id symbol){
    assert(symbolp(symbol));
    symbol_t* s=unbox_symbol(symbol);
    return(s->plist);}

id symbol_set_value(id symbol,id value){
    assert(symbolp(symbol));
    symbol_t* s=unbox_symbol(symbol);
    s->value=value;
    return(value);}

id symbol_set_function(id symbol,id function){
    assert(symbolp(symbol));
    symbol_t* s=unbox_symbol(symbol);
    s->function=function;
    return(function);}

id symbol_set_plist(id symbol,id plist){
    assert(symbolp(symbol));
    symbol_t* s=unbox_symbol(symbol);
    s->plist=plist;
    return(plist);}


typedef struct package {
    id name;
    id symbols;
} package_t;

id find_package(id name);

id make_package(id name){
    assert(not(find_package(name)));
    package_t* pack=memory_allocate(__FUNCTION__,sizeof(*pack),1);
    pack->name=name;
    pack->symbols=make_hashtable(17);
    return(box(ot_package,pack));}

id packagep(id object){
    return(boolean(not(null(object)) and (ot_package==type_of(object))));}

package_t* unbox_package(id object){
    assert(nil!=object);
    assert(ot_package==type_of(object));
    return(object->value.package);}

id package_name(id package){
    assert(packagep(package));
    package_t* p=unbox_package(package);
    return(p->name);}

id package_symbols(id package){
    assert(packagep(package));
    package_t* p=unbox_package(package);
    return(p->symbols);}

id find_package(id name){
    id p=all_packages;
    while(p and not(equal(name,package_name(car(p))))){
        p=cdr(p);}
    return(car(p));}

id intern(id name,id pack){
    assert(stringp(name));
    assert(null(pack) or stringp(pack) or packagep(pack));
    id the_package;
    if(null(pack)){
        the_package=package;}
    else if(stringp(pack)){
        the_package=find_package(pack);
        if(null(the_package)){
            ERROR("No package named \"%s\"",unbox_string(name));}}
    else if(packagep(pack)){
        the_package=pack;}
    id syms=package_symbols(the_package);
    id sym=hashtable_get(syms,name);
    if(null(sym)){
        sym=make_symbol(name,the_package);
        hashtable_set(syms,name,sym);}
    return(sym);}


void initialize(void){
    ONCE({
              standard_input=stream(stdin);
              standard_output=stream(stdout);
              error_output=stream(stderr);
              trace_output=error_output;
              objects_being_printed=make_hashtable(10000);
              keyword=make_package(string("keyword"));
              PUSH(keyword,all_packages);
              user=make_package(string("user"));
              PUSH(user,all_packages);
              package=user;
              t=SY(t);
              symbol_set_value(t,t);
              SY(nil);});}


id terpri(id stream){
    assert(null(stream) or streamp(stream));
    if(null(stream)){
        stream=standard_output;}
    fprintf(unbox_stream(stream),"\n");
    return(nil);}


id prin1_object(id object,FILE* file);

void scan_object_sharing(id object,id table){
    // We enter into the table all the non trivial objects,
    // mapped to an integer number-of-occurences.
    if(not(null(object))){
        switch(type_of(object)){
          case ot_int:    break;
          case ot_char:   break;
          case ot_symbol: break;
          default:{
              id ref=hashtable_get(table,object);
              if(null(ref)){
                  hashtable_set(table,object,integer(1));
                  switch(type_of(object)){
                    case ot_cons:
                        scan_object_sharing(car(object),table);
                        scan_object_sharing(cdr(object),table);
                        break;
                    case ot_vector:
                        if(ot_t==vector_element_type(object)){
                            DOTIMES(i,length(object),{scan_object_sharing(vector_get(object,i),table);});}
                        break;
                    default:
                        break;}}
              else{
                  hashtable_set(table,object,integer(1+unbox_integer(ref)));}}}}}

typedef struct {
    id table;
    int count;
} object_sharing_cleanup_closure;

void clean_object(id key,id ref,void* data){
    // This removes the entries that have ref==1
    // and replaces the others by a cons (nil . unique-ident)
    object_sharing_cleanup_closure* closure=data;
    if(1==unbox_integer(ref)){
        hashtable_remove(closure->table,key);}
    else{
        hashtable_set(closure->table,key,cons(nil,integer(INCF(closure->count))));}}

void clean_object_sharing(id table){
    object_sharing_cleanup_closure closure;
    closure.table=table;
    closure.count=0;
    hashtable_map(table,clean_object,&closure);}


id prin1(id object,id stream){
    assert(null(stream) or streamp(stream));
    if(null(stream)){
        stream=standard_output;}
    hashtable_clear(objects_being_printed);
    if(print_circle){
        scan_object_sharing(object,objects_being_printed);
        clean_object_sharing(objects_being_printed);}
    prin1_object(object,unbox_stream(stream));
    return(object);}

id princ(id object,id stream){
    assert(null(stream) or streamp(stream));
    if(null(stream)){
        stream=standard_output;}
    if(print_circle){
        hashtable_clear(objects_being_printed);}
    if(characterp(object)){
        fprintf(unbox_stream(stream),"%c",unbox_character(object));}
    else if(stringp(object)){
        fprintf(unbox_stream(stream),"%s",unbox_string(object));}
    else if(symbolp(object)){
        fprintf(unbox_stream(stream),"%s",unbox_string(symbol_name(object)));}
    else{
        hashtable_clear(objects_being_printed);
        prin1_object(object,unbox_stream(stream));}
    return(object);}

id print(id object,id stream){
    terpri(stream);
    return(prin1(object,stream));}


typedef id(*predicate)(id object);

id every(predicate fun,id sequence){
    if(null(sequence)){
        return(t);}
    else if(consp(sequence)){
        while(sequence and fun(car(sequence))){
            sequence=cdr(sequence);}
        return(boolean(not(sequence)));}
    else if(vectorp(sequence)){
        int len=length(sequence);
        int i=0;
        while((i<len) and fun(vector_get(sequence,i))){
            INCF(i);}
        return(boolean(not(i<len)));}
    else{
        ERROR("Expected a sequence, not a %s",type_name(type_of(sequence)));}}

id unescaped_character_p(id ch){
    return(boolean(0!=strchr("$%&*+,-./0123456789<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_abcdefghijklmnopqrstuvwxyz~",unbox_character(ch))));}

id prin1_escaped_name(id name,FILE* file){
    assert(stringp(name));
    if(every(unescaped_character_p,name)){
        fprintf(file,"%s",unbox_string(name));}
    else{
        int len=length(name);
        for(int i=0;i<len;INCF(i)){
            id ch=vector_get(name,i);
            if(not(unescaped_character_p(ch))){
                fprintf(file,"\\");}
            fprintf(file,"%c",unbox_character(ch));}}
    return(name);}

id prin1_symbol(id object,FILE* file){
    assert(symbolp(object));
    id p=symbol_package(object);
    id n=symbol_name(object);
    if(p!=package){
        if(p==keyword){
            fprintf(file,":");}
        else{
            prin1_escaped_name(package_name(p),file);
            fprintf(file,":");;}}
    prin1_escaped_name(n,file);
    return(object);}

id prin1_string(id object,FILE* file){
    assert(vectorp(object) and (ot_char==vector_element_type(object)));
    fprintf(file,"\"");
    int count=vector_length(object);
    for(int i=0;i<count;INCF(i)){
        char ch=vector_get_char(object,i);
        if(('"'==ch)or('\\'==ch)){
            fprintf(file,"\\%c",ch);}
        else{
            fprintf(file,"%c",ch);}}
    fprintf(file,"\"");
    return(object);}

id prin1_vector(id object,FILE* file){
    assert(vectorp(object));
    int count=vector_length(object);
    const char* sep="";
    switch(vector_element_type(object)){
      case ot_char:
          prin1_string(object,file);
          break;
      case ot_int:{
          fprintf(file,"#(");
          for(int i=0;i<count;INCF(i)){
              fprintf(file,"%s"INTEGER_FMT,sep,vector_get_int(object,i));
              sep=" ";}
          fprintf(file,")");
          break;}
      case ot_t:{
          fprintf(file,"#(");
          for(int i=0;i<count;INCF(i)){
              prin1_object(vector_get(object,i),file);
              sep=" ";}
          fprintf(file,")");
          break;}
      default:
          fprintf(file,"#<vector unexpected element type %d>",vector_element_type(object));
          break;}
    return(object);}

id prin1_list(id object,FILE* file){
    if(null(object)){
        fprintf(file,"nil");}
    else{
        id ref=hashtable_get(objects_being_printed,object);
        if(car(ref)){
            fprintf(file,"#"INTEGER_FMT"#",unbox_integer(cdr(ref)));}
        else{
            if(ref){
                fprintf(file,"#"INTEGER_FMT"=",unbox_integer(cdr(ref)));
                setcar(ref,t);}
            id current=object;
            fprintf(file,"(");
            prin1_object(car(current),file);
            while(consp(current=cdr(current))){
                id ref=hashtable_get(objects_being_printed,current);
                if(car(ref)){
                    fprintf(file," . #"INTEGER_FMT"#)",unbox_integer(cdr(ref)));
                    return(object);}
                else if(ref){
                        fprintf(file," . ");
                        prin1_object(current,file);
                        fprintf(file,")");
                        return(object);}
                else{
                    fprintf(file," ");
                    prin1_object(car(current),file);}}
            if(not(null(current))){
                fprintf(file," . ");
                prin1_object(current,file);}
            fprintf(file,")");}}
    return(object);}

id prin1_object(id object,FILE* file){
    if(null(object)){
        fprintf(file,"nil");}
    else{
        switch(type_of(object)){
          case ot_int:
              fprintf(file,INTEGER_FMT,unbox_integer(object));
              break;
          case ot_char:{
              char chname[20];
              char ch=unbox_character(object);
              switch(ch){
                case ' ':  strcpy(chname,"space");   break;
                case '\n': strcpy(chname,"newline"); break;
                default:
                    if(!isgraph(ch)){
                        sprintf(chname,"U+%04X",ch);}
                    break;}
              if(chname){
                  fprintf(file,"#\\%s",chname);}
              else{
                  fprintf(file,"#\\%c",ch);}
              break;}
          case ot_symbol:
              prin1_symbol(object,file);
              break;
          case ot_cons:
              prin1_list(object,file);
              break;
          default:{
              id ref=hashtable_get(objects_being_printed,object);
              if(car(ref)){
                  fprintf(file,"#"INTEGER_FMT"#",unbox_integer(cdr(ref)));}
              else{
                  if(ref){
                      fprintf(file,"#"INTEGER_FMT"=",unbox_integer(cdr(ref)));
                      setcar(ref,t);}
                  switch(type_of(object)){
                    case ot_CXType:
                        fprintf(file,"#<CXType %p>",object);
                        break;
                    case ot_CXToken:
                        fprintf(file,"#<CXToken %u>",sxhash(object));
                        break;
                    case ot_CXCursor:
                        fprintf(file,"#<CXCursor %u>",sxhash(object));
                        break;
                    case ot_CXSourceRange:
                        fprintf(file,"#<CXSourceRange %u>",sxhash(object));
                        break;
                    case ot_CXSourceLocation:
                        fprintf(file,"#<CXSourceLocation %u>",sxhash(object));
                        break;
                    case ot_CXTranslationUnit:
                        fprintf(file,"#<CXTranslationUnit %u>",sxhash(object));
                        break;
                    case ot_stream:{
                        const char* name=0;
                        FILE* file=unbox_stream(object);
                        if(file==stdout){ name="stdout"; }
                        else if(file==stderr){ name="stderr"; }
                        else if(file==stdin){ name="stdin"; }
                        if(name){
                            fprintf(file,"#<stream %s>",name);}
                        else{
                            fprintf(file,"#<stream %p>",file);}
                        break;}
                    case ot_vector:
                        if(stringp(object)){
                            prin1_string(object,file);}
                        else{
                            prin1_vector(object,file);}
                        break;
                    case ot_package:
                        fprintf(file,"#<package %s>",unbox_string(package_name(object)));
                        break;
                    case ot_hashtable:
                        fprintf(file,"#<hashtable :count %d>",hashtable_count(object));
                        break;
                    default:
                        fprintf(file,"#<object of unexpected type %d>",type_of(object));
                        break;}}}}}
    return(object);}



//// arguments

id argv_to_list(const char* const* argv){
    id args=nil;
    for(int i=0;argv[i];INCF(i)){
        PUSH(string(argv[i]),args);}
    return(nreverse(args));}

const char* const* list_to_argv(id args){
    int cnt=length(args);
    const char** result=memory_allocate(__FUNCTION__,sizeof(char*),(1+cnt));
    for(int i=0;i<cnt;INCF(i),args=rest(args)){
        assert(stringp(car(args)));
        result[i]=unbox_string(car(args));}
    result[cnt]=0;
    return(result);}

int argv_count(const char* const* argv){
    // /*DEBUG*/printf("%s(...)\n",__FUNCTION__); fflush(stdout);
    int cnt=0;
    while(argv[cnt]){
        INCF(cnt);}

    return(cnt);}

const char* const* argv_concat(const char* const* argv1,const char* const* argv2){
    // /*DEBUG*/printf("%s(...)\n",__FUNCTION__); fflush(stdout);
    int cnt1=argv_count(argv1);
    int cnt2=argv_count(argv2);
    const char** result=memory_allocate(__FUNCTION__,sizeof(char*),(1+cnt1+cnt2));
    int s=0;
    int d=0;
    for(s=0;s<cnt1;INCF(s)){
        result[d++]=argv1[s];}
    for(s=0;s<cnt2;INCF(s)){
        result[d++]=argv2[s];}
    result[d]=0;
    return(result);}


//// clang-c


id cursorSymbol(int cursorKind){
    switch(cursorKind){
      case CXCursor_UnexposedDecl:                      return SY(unexposed-decl);
      case CXCursor_StructDecl:                         return SY(struct-decl);
      case CXCursor_UnionDecl:                          return SY(union-decl);
      case CXCursor_ClassDecl:                          return SY(class-decl);
      case CXCursor_EnumDecl:                           return SY(enum-decl);
      case CXCursor_FieldDecl:                          return SY(field-decl);
      case CXCursor_EnumConstantDecl:                   return SY(enum-constant-decl);
      case CXCursor_FunctionDecl:                       return SY(function-decl);
      case CXCursor_VarDecl:                            return SY(var-decl);
      case CXCursor_ParmDecl:                           return SY(parm-decl);
      case CXCursor_ObjCInterfaceDecl:                  return SY(objc-interface-decl);
      case CXCursor_ObjCCategoryDecl:                   return SY(objc-category-decl);
      case CXCursor_ObjCProtocolDecl:                   return SY(objc-protocol-decl);
      case CXCursor_ObjCPropertyDecl:                   return SY(objc-property-decl);
      case CXCursor_ObjCIvarDecl:                       return SY(objc-ivar-decl);
      case CXCursor_ObjCInstanceMethodDecl:             return SY(objc-instance-method-decl);
      case CXCursor_ObjCClassMethodDecl:                return SY(objc-class-method-decl);
      case CXCursor_ObjCImplementationDecl:             return SY(objc-implementation-decl);
      case CXCursor_ObjCCategoryImplDecl:               return SY(objc-category-impl-decl);
      case CXCursor_TypedefDecl:                        return SY(typedef-decl);
      case CXCursor_CXXMethod:                          return SY(cxx-method);
      case CXCursor_Namespace:                          return SY(namespace);
      case CXCursor_LinkageSpec:                        return SY(linkage-spec);
      case CXCursor_Constructor:                        return SY(constructor);
      case CXCursor_Destructor:                         return SY(destructor);
      case CXCursor_ConversionFunction:                 return SY(conversion-function);
      case CXCursor_TemplateTypeParameter:              return SY(template-type-parameter);
      case CXCursor_NonTypeTemplateParameter:           return SY(non-type-template-parameter);
      case CXCursor_TemplateTemplateParameter:          return SY(template-template-parameter);
      case CXCursor_FunctionTemplate:                   return SY(function-template);
      case CXCursor_ClassTemplate:                      return SY(class-template);
      case CXCursor_ClassTemplatePartialSpecialization: return SY(class-template-partial-specialization);
      case CXCursor_NamespaceAlias:                     return SY(namespace-alias);
      case CXCursor_UsingDirective:                     return SY(using-directive);
      case CXCursor_UsingDeclaration:                   return SY(using-declaration);
      case CXCursor_TypeAliasDecl:                      return SY(type-alias-decl);
      case CXCursor_ObjCSynthesizeDecl:                 return SY(objc-synthesize-decl);
      case CXCursor_ObjCDynamicDecl:                    return SY(objc-dynamic-decl);
      case CXCursor_CXXAccessSpecifier:                 return SY(cxx-access-specifier);
      case CXCursor_ObjCSuperClassRef:                  return SY(objc-super-class-ref);
      case CXCursor_ObjCProtocolRef:                    return SY(objc-protocol-ref);
      case CXCursor_ObjCClassRef:                       return SY(objc-class-ref);
      case CXCursor_TypeRef:                            return SY(type-ref);
      case CXCursor_CXXBaseSpecifier:                   return SY(cxx-base-specifier);
      case CXCursor_TemplateRef:                        return SY(template-ref);
      case CXCursor_NamespaceRef:                       return SY(namespace-ref);
      case CXCursor_MemberRef:                          return SY(member-ref);
      case CXCursor_LabelRef:                           return SY(label-ref);
      case CXCursor_OverloadedDeclRef:                  return SY(overloaded-decl-ref);
      case CXCursor_VariableRef:                        return SY(variable-ref);
      case CXCursor_InvalidFile:                        return SY(invalid-file);
      case CXCursor_NoDeclFound:                        return SY(no-decl-found);
      case CXCursor_NotImplemented:                     return SY(not-implemented);
      case CXCursor_InvalidCode:                        return SY(invalid-code);
      case CXCursor_UnexposedExpr:                      return SY(unexposed-expr);
      case CXCursor_DeclRefExpr:                        return SY(decl-ref-expr);
      case CXCursor_MemberRefExpr:                      return SY(member-ref-expr);
      case CXCursor_CallExpr:                           return SY(call-expr);
      case CXCursor_ObjCMessageExpr:                    return SY(objc-message-expr);
      case CXCursor_BlockExpr:                          return SY(block-expr);
      case CXCursor_IntegerLiteral:                     return SY(integer-literal);
      case CXCursor_FloatingLiteral:                    return SY(floating-literal);
      case CXCursor_ImaginaryLiteral:                   return SY(imaginary-literal);
      case CXCursor_StringLiteral:                      return SY(string-literal);
      case CXCursor_CharacterLiteral:                   return SY(character-literal);
      case CXCursor_ParenExpr:                          return SY(paren-expr);
      case CXCursor_UnaryOperator:                      return SY(unary-operator);
      case CXCursor_ArraySubscriptExpr:                 return SY(array-subscript-expr);
      case CXCursor_BinaryOperator:                     return SY(binary-operator);
      case CXCursor_CompoundAssignOperator:             return SY(compound-assign-operator);
      case CXCursor_ConditionalOperator:                return SY(conditional-operator);
      case CXCursor_CStyleCastExpr:                     return SY(cstyle-cast-expr);
      case CXCursor_CompoundLiteralExpr:                return SY(compound-literal-expr);
      case CXCursor_InitListExpr:                       return SY(init-list-expr);
      case CXCursor_AddrLabelExpr:                      return SY(addr-label-expr);
      case CXCursor_StmtExpr:                           return SY(stmt-expr);
      case CXCursor_GenericSelectionExpr:               return SY(generic-selection-expr);
      case CXCursor_GNUNullExpr:                        return SY(gnunull-expr);
      case CXCursor_CXXStaticCastExpr:                  return SY(cxx-static-cast-expr);
      case CXCursor_CXXDynamicCastExpr:                 return SY(cxx-dynamic-cast-expr);
      case CXCursor_CXXReinterpretCastExpr:             return SY(cxx-reinterpret-cast-expr);
      case CXCursor_CXXConstCastExpr:                   return SY(cxx-const-cast-expr);
      case CXCursor_CXXFunctionalCastExpr:              return SY(cxx-functional-cast-expr);
      case CXCursor_CXXTypeidExpr:                      return SY(cxx-typeid-expr);
      case CXCursor_CXXBoolLiteralExpr:                 return SY(cxx-bool-literal-expr);
      case CXCursor_CXXNullPtrLiteralExpr:              return SY(cxx-null-ptr-literal-expr);
      case CXCursor_CXXThisExpr:                        return SY(cxx-this-expr);
      case CXCursor_CXXThrowExpr:                       return SY(cxx-throw-expr);
      case CXCursor_CXXNewExpr:                         return SY(cxx-new-expr);
      case CXCursor_CXXDeleteExpr:                      return SY(cxx-delete-expr);
      case CXCursor_UnaryExpr:                          return SY(unary-expr);
      case CXCursor_ObjCStringLiteral:                  return SY(objc-string-literal);
      case CXCursor_ObjCEncodeExpr:                     return SY(objc-encode-expr);
      case CXCursor_ObjCSelectorExpr:                   return SY(objc-selector-expr);
      case CXCursor_ObjCProtocolExpr:                   return SY(objc-protocol-expr);
      case CXCursor_ObjCBridgedCastExpr:                return SY(objc-bridged-cast-expr);
      case CXCursor_PackExpansionExpr:                  return SY(pack-expansion-expr);
      case CXCursor_SizeOfPackExpr:                     return SY(size-of-pack-expr);
      case CXCursor_LambdaExpr:                         return SY(lambda-expr);
      case CXCursor_ObjCBoolLiteralExpr:                return SY(objc-bool-literal-expr);
      case CXCursor_UnexposedStmt:                      return SY(unexposed-stmt);
      case CXCursor_LabelStmt:                          return SY(label-stmt);
      case CXCursor_CompoundStmt:                       return SY(compound-stmt);
      case CXCursor_CaseStmt:                           return SY(case-stmt);
      case CXCursor_DefaultStmt:                        return SY(default-stmt);
      case CXCursor_IfStmt:                             return SY(if-stmt);
      case CXCursor_SwitchStmt:                         return SY(switch-stmt);
      case CXCursor_WhileStmt:                          return SY(while-stmt);
      case CXCursor_DoStmt:                             return SY(do-stmt);
      case CXCursor_ForStmt:                            return SY(for-stmt);
      case CXCursor_GotoStmt:                           return SY(goto-stmt);
      case CXCursor_IndirectGotoStmt:                   return SY(indirect-goto-stmt);
      case CXCursor_ContinueStmt:                       return SY(continue-stmt);
      case CXCursor_BreakStmt:                          return SY(break-stmt);
      case CXCursor_ReturnStmt:                         return SY(return-stmt);
      case CXCursor_GCCAsmStmt:                         return SY(gccasm-stmt);
      case CXCursor_ObjCAtTryStmt:                      return SY(objc-at-try-stmt);
      case CXCursor_ObjCAtCatchStmt:                    return SY(objc-at-catch-stmt);
      case CXCursor_ObjCAtFinallyStmt:                  return SY(objc-at-finally-stmt);
      case CXCursor_ObjCAtThrowStmt:                    return SY(objc-at-throw-stmt);
      case CXCursor_ObjCAtSynchronizedStmt:             return SY(objc-at-synchronized-stmt);
      case CXCursor_ObjCAutoreleasePoolStmt:            return SY(objc-autorelease-pool-stmt);
      case CXCursor_ObjCForCollectionStmt:              return SY(objc-for-collection-stmt);
      case CXCursor_CXXCatchStmt:                       return SY(cxx-catch-stmt);
      case CXCursor_CXXTryStmt:                         return SY(cxx-try-stmt);
      case CXCursor_CXXForRangeStmt:                    return SY(cxx-for-range-stmt);
      case CXCursor_SEHTryStmt:                         return SY(seh-try-stmt);
      case CXCursor_SEHExceptStmt:                      return SY(seh-except-stmt);
      case CXCursor_SEHFinallyStmt:                     return SY(seh-finally-stmt);
      case CXCursor_MSAsmStmt:                          return SY(msasm-stmt);
      case CXCursor_NullStmt:                           return SY(null-stmt);
      case CXCursor_DeclStmt:                           return SY(decl-stmt);
      case CXCursor_TranslationUnit:                    return SY(translation-unit);
      case CXCursor_UnexposedAttr:                      return SY(unexposed-attr);
      case CXCursor_IBActionAttr:                       return SY(ibaction-attr);
      case CXCursor_IBOutletAttr:                       return SY(iboutlet-attr);
      case CXCursor_IBOutletCollectionAttr:             return SY(iboutlet-collection-attr);
      case CXCursor_CXXFinalAttr:                       return SY(cxx-final-attr);
      case CXCursor_CXXOverrideAttr:                    return SY(cxx-override-attr);
      case CXCursor_AnnotateAttr:                       return SY(annotate-attr);
      case CXCursor_AsmLabelAttr:                       return SY(asm-label-attr);
      case CXCursor_PreprocessingDirective:             return SY(preprocessing-directive);
      case CXCursor_MacroDefinition:                    return SY(macro-definition);
      case CXCursor_MacroExpansion:                     return SY(macro-expansion);
      case CXCursor_InclusionDirective:                 return SY(inclusion-directive);
      case CXCursor_ModuleImportDecl:                   return SY(module-import-decl);
      default:                                          return SY(unexpected);}}

id cursorLinkage(int linkageKind){
    switch(linkageKind){
      case CXLinkage_Invalid:        return KW(invalid);
      case CXLinkage_NoLinkage:      return KW(no-linkage);
      case CXLinkage_Internal:       return KW(internal);
      case CXLinkage_UniqueExternal: return KW(unique-external);
      case CXLinkage_External:       return KW(external);
      default:                       return KW(unexpected);}}

id cursorLanguageKind(int languageKind){
    switch(languageKind){
      case CXLanguage_Invalid:   return KW(invalid);
      case CXLanguage_C:         return KW(c);
      case CXLanguage_ObjC:      return KW(objc);
      case CXLanguage_CPlusPlus: return KW(cxx);
      default:                   return KW(unexpected);}}

id cursorAvailability(int availabilityKind){
    switch(availabilityKind){
      case CXAvailability_Available:     return KW(available);
      case CXAvailability_Deprecated:    return KW(deprecated);
      case CXAvailability_NotAvailable:  return KW(not-available);
      case CXAvailability_NotAccessible: return KW(not-accessible);
      default:                           return KW(unexpected);}}

id tokenSymbol(int tokenKind){
    switch(tokenKind){
      case CXToken_Punctuation: return(SY(punctuation));
      case CXToken_Keyword:     return(SY(keyword));
      case CXToken_Identifier:  return(SY(identifier));
      case CXToken_Literal:     return(SY(literal));
      case CXToken_Comment:     return(SY(comment));
      default:                  return(SY(unexpected));}}

id typeSymbol(int typeKind){
    switch(typeKind){
      case CXType_Invalid:                  return SY(Invalid);
      case CXType_Unexposed:                return SY(Unexposed);
      case CXType_Void:                     return SY(Void);
      case CXType_Bool:                     return SY(Bool);
      case CXType_Char_U:                   return SY(Char-U);
      case CXType_UChar:                    return SY(unsigned-Char);
      case CXType_Char16:                   return SY(Char-16);
      case CXType_Char32:                   return SY(Char-32);
      case CXType_UShort:                   return SY(unsigned-Short);
      case CXType_UInt:                     return SY(unsigned-Int);
      case CXType_ULong:                    return SY(unsigned-Long);
      case CXType_ULongLong:                return SY(unsigned-Long-Long);
      case CXType_UInt128:                  return SY(unsigned-Int-128);
      case CXType_Char_S:                   return SY(Char-S);
      case CXType_SChar:                    return SY(Signed-Char);
      case CXType_WChar:                    return SY(Wide-Char);
      case CXType_Short:                    return SY(Short);
      case CXType_Int:                      return SY(Int);
      case CXType_Long:                     return SY(Long);
      case CXType_LongLong:                 return SY(Long-Long);
      case CXType_Int128:                   return SY(Int-128);
      case CXType_Float:                    return SY(c-Float);
      case CXType_Double:                   return SY(Double);
      case CXType_LongDouble:               return SY(Long-Double);
      case CXType_NullPtr:                  return SY(Null-Pointer);
      case CXType_Overload:                 return SY(Overload);
      case CXType_Dependent:                return SY(Dependent);
      case CXType_ObjCId:                   return SY(ObjC-Id);
      case CXType_ObjCClass:                return SY(ObjC-Class);
      case CXType_ObjCSel:                  return SY(ObjC-Selector);
      case CXType_Complex:                  return SY(c-Complex);
      case CXType_Pointer:                  return SY(Pointer);
      case CXType_BlockPointer:             return SY(Block-Pointer);
      case CXType_LValueReference:          return SY(left-Value-Reference);
      case CXType_RValueReference:          return SY(right-Value-Reference);
      case CXType_Record:                   return SY(Record);
      case CXType_Enum:                     return SY(Enum);
      case CXType_Typedef:                  return SY(Typedef);
      case CXType_ObjCInterface:            return SY(ObjC-Interface);
      case CXType_ObjCObjectPointer:        return SY(ObjC-Object-Pointer);
      case CXType_FunctionNoProto:          return SY(Function-No-Proto);
      case CXType_FunctionProto:            return SY(Function-Proto);
      case CXType_ConstantArray:            return SY(Constant-Array);
      case CXType_Vector:                   return SY(c-Vector);
      default:                              return SY(unexpected); }}

id callingConvention(int cc){
    switch(cc){
      case CXCallingConv_Default:           return KW(Default);
      case CXCallingConv_C:                 return KW(C);
      case CXCallingConv_X86StdCall:        return KW(X86StdCall);
      case CXCallingConv_X86FastCall:       return KW(X86FastCall);
      case CXCallingConv_X86ThisCall:       return KW(X86ThisCall);
      case CXCallingConv_X86Pascal:         return KW(X86Pascal);
      case CXCallingConv_AAPCS:             return KW(AAPCS);
      case CXCallingConv_AAPCS_VFP:         return KW(AAPCS_VFP);
      case CXCallingConv_PnaclCall:         return KW(PnaclCall);
          // case CXCallingConv_IntelOclBicc:      return KW(IntelOclBicc);
          // case CXCallingConv_Invalid:           return KW(Invalid);
      case CXCallingConv_Unexposed:         return KW(Unexposed);
      default:                              return KW(unexpected); }}

id accessSpecifier(int as){
    switch(as){
      case CX_CXXInvalidAccessSpecifier: return KW(invalid);
      case CX_CXXPublic:                 return KW(public);
      case CX_CXXProtected:              return KW(protected);
      case CX_CXXPrivate:                return KW(private);
      default:                           return KW(unexpected);}}


id cxstring_dispose(CXString theCXString,int dispose){
    const char* cstring=clang_getCString(theCXString);
    id result=((nil==cstring)
               ?nil
               :string(cstring));
    if(dispose){
        clang_disposeString(theCXString);}
    return(result);}

id cxstring(CXString theCXString){
    return(cxstring_dispose(theCXString,1));}

id cxversion(CXVersion version){
    return(list(3,
                integer(version.Major),
                integer(version.Minor),
                integer(version.Subminor)));}


id platform_availability(CXCursor cxcursor){
    int platformCount=clang_getCursorPlatformAvailability(cxcursor,0,0,0,0,0,0);
    int always_deprecated=0;
    int always_unavailable=0;
    CXString deprecated_message;
    CXString unavailable_message;
    id platformAvailabilities=nil;
    if(platformCount!=0){
        CXPlatformAvailability* availability=memory_allocate(__FUNCTION__,sizeof(*availability),platformCount);
        platformCount=clang_getCursorPlatformAvailability(cxcursor,
                                                          &always_deprecated,
                                                          &deprecated_message,
                                                          &always_unavailable,
                                                          &unavailable_message,
                                                          availability,
                                                          platformCount);
        DOTIMES(i,platformCount,
                {PUSH(list(13,
                           SY(platform-availability),
                           KW(platform),cxstring_dispose(availability[i].Platform,0),
                           KW(introduced),cxversion(availability[i].Introduced),
                           KW(deprecated),cxversion(availability[i].Deprecated),
                           KW(obsoleted),cxversion(availability[i].Obsoleted),
                           KW(unavailable),boolean(availability[i].Unavailable),
                           KW(message),cxstring_dispose(availability[i].Message,0)),
                      platformAvailabilities);
                 clang_disposeCXPlatformAvailability(&(availability[i]));});}
    if(not(always_deprecated) and not(always_unavailable) and (0==platformCount)){
        return(nil);}
    else{
        return(list(11,
                    SY(availability),
                    KW(always-deprecated),boolean(always_deprecated),
                    KW(always-deprecated-message),cxstring(deprecated_message),
                    KW(always-unavailable),boolean(always_unavailable),
                    KW(always-unavailable-message),cxstring(unavailable_message),
                    KW(platforms),platformAvailabilities));}}

id location_sexp(id location){
    CXFile file;
    unsigned line;
    unsigned column;
    unsigned offset;
    clang_getSpellingLocation(unbox_location(location),&file,&line,&column,&offset);
    return(list(9,SY(location),
                KW(file),(null(file)?nil:cxstring(clang_getFileName(file))),
                KW(line),integer(line),
                KW(column),integer(column),
                KW(offset),integer(offset)));}

id range_sexp(id range){
    return(list(5,SY(range),
                KW(start),location_sexp(location(clang_getRangeStart(unbox_range(range)))),
                KW(end),location_sexp(location(clang_getRangeEnd(unbox_range(range))))));}


typedef struct {
    enum CXChildVisitResult result;
    id cursors;
} collect_cursor_visitor_closure;

enum CXChildVisitResult collect_cursor_visitor(CXCursor cxcursor,CXCursor parent,CXClientData client_data){
    collect_cursor_visitor_closure* closure=client_data;
    PUSH(cursor(cxcursor),closure->cursors);
    return(closure->result);}

id cursor_children(id cursor){
    collect_cursor_visitor_closure closure;
    closure.result=CXChildVisit_Continue; // not recursive.
    closure.cursors=nil;
    clang_visitChildren(unbox_cursor(cursor),collect_cursor_visitor,&closure);
    return(nreverse(closure.cursors));}

id cursor_range(id cursor){
    return(range(clang_getCursorExtent(unbox_cursor(cursor))));}



id conversion_object_info=0;
int cxobject_counter=0;

void conversion_initialize(){
    ONCE({
              initialize();
              conversion_object_info=make_hashtable(10000);});}


void cxobject_next_id(id cxobject);

void cxobject_set_value(id cxobject,id key,id value){
    id entry=hashtable_get(conversion_object_info,cxobject);
    if(entry){
        id subentry=assoc(key,entry);
        if(subentry){
            setcdr(subentry,value);}
        else{
            setcdr(last(entry),acons(key,value,nil));}}
    else{
        hashtable_set(conversion_object_info,cxobject,acons(key,value,nil));
        cxobject_next_id(cxobject);}}

id cxobject_get_value(id cxobject,id key){
    id entry=hashtable_get(conversion_object_info,cxobject);
    if(entry){
        id subentry=assoc(key,entry);
        if(subentry){
            return(cdr(subentry));}}
    return(nil);}

void cxobject_set_token(id cxobject,id token){
    cxobject_set_value(cxobject,KW(token),token);}

id cxobject_token(id cxobject){
    return(cxobject_get_value(cxobject,KW(token)));}

void cxobject_set_token_info(id cxobject,id token_kind,id token_spelling){
    cxobject_set_value(cxobject,KW(token-kind),token_kind);
    cxobject_set_value(cxobject,KW(token-spelling),token_spelling);}

id cxobject_token_kind(id cxobject){
    return(cxobject_get_value(cxobject,KW(token-kind)));}

id cxobject_token_spelling(id cxobject){
    return(cxobject_get_value(cxobject,KW(token-spelling)));}

void cxobject_set_sexp(id cxobject,id sexp){
    cxobject_set_value(cxobject,KW(sexp),sexp);}

id cxobject_sexp(id cxobject){
    return(cxobject_get_value(cxobject,KW(sexp)));}

void cxobject_next_id(id cxobject){
    cxobject_set_value(cxobject,KW(id),integer(INCF(cxobject_counter)));}

id cxobject_id(id cxobject){
    return(cxobject_get_value(cxobject,KW(id)));}


#define NCONCF(PLACE,LIST) PLACE=nconc(2,PLACE,LIST)
#define NCONCF2(PLACE,KEY,VALUE) PLACE=nconc(2,PLACE,list(2,KEY,VALUE))

id type_sexp(id tipe){
    CXType cxtype=unbox_type(tipe);
    int kind=cxtype.kind;
    id result=list(3,typeSymbol(kind),
                   KW(kind-spelling),cxstring(clang_getTypeKindSpelling(kind)));
    if(clang_isConstQualifiedType(cxtype)){
        NCONCF2(result,KW(const),t);}
    if(clang_isVolatileQualifiedType(cxtype)){
        NCONCF2(result,KW(volatile),t);}
    if(clang_isRestrictQualifiedType(cxtype)){
        NCONCF2(result,KW(restrict),t);}
    if(clang_isPODType(cxtype)){
        NCONCF2(result,KW(pod-type),t);}
    CXType canonicalType=clang_getCanonicalType(cxtype);
    if(CXType_Invalid!=canonicalType.kind){
        NCONCF2(result,KW(canonical-type),type(canonicalType));}
    CXCursor declaration=clang_getTypeDeclaration(cxtype);
    if(not(clang_Cursor_isNull(declaration))){
        NCONCF2(result,KW(declaration),cursor(declaration));}
    CXType elementType=clang_getElementType(cxtype);
    if(CXType_Invalid!=elementType.kind){
        NCONCF2(result,KW(element-type),type(elementType));}
    long long numElems=clang_getNumElements(cxtype);
    if(0<=numElems){
        NCONCF2(result,KW(number-of-elements),integer(numElems));}
    CXType arrayElementType=clang_getArrayElementType(cxtype);
    if(CXType_Invalid!=arrayElementType.kind){
        NCONCF2(result,KW(array-element-type),type(arrayElementType));}
    long long arraySize=clang_getArraySize(cxtype);
    if(0<=arraySize){
        NCONCF2(result,KW(array-size),integer(arraySize));}
    CXType pointee=clang_getPointeeType(cxtype);
    if(CXType_Invalid!=pointee.kind){
        NCONCF2(result,KW(pointee),type(pointee));}
    enum CXCallingConv callingConv=clang_getFunctionTypeCallingConv(cxtype);
    if(CXCallingConv_Invalid!=callingConv){
        NCONCF2(result,KW(calling-convention),callingConvention(callingConv));}
    CXType resultType=clang_getResultType(cxtype);
    if(CXType_Invalid!=resultType.kind){
        NCONCF2(result,KW(result-type),type(resultType));}
    int numArgs=clang_getNumArgTypes(cxtype);
    if(0<=numArgs){
        id arguments=nil;
        DOTIMES(i,numArgs,
                { PUSH(type(clang_getArgType(cxtype,i)),arguments); });
        NCONCF2(result,KW(arguments),cons(SY(list),nreverse(arguments)));}
    if(clang_isFunctionTypeVariadic(cxtype)){
        NCONCF2(result,KW(variadic),t);}
    return(result);}


id token_kind(id token){
    return(tokenSymbol(clang_getTokenKind(unbox_token(token))));}

id token_spelling(id token,id tu){
    return(cxstring(clang_getTokenSpelling(unbox_translation_unit(tu),unbox_token(token))));}

id token_location(id token,id tu){
    return(location(clang_getTokenLocation(unbox_translation_unit(tu),unbox_token(token))));}

id token_range(id token,id tu){
    return(range(clang_getTokenExtent(unbox_translation_unit(tu),unbox_token(token))));}

id token_sexp(id token,id tu){
    return((null(tu))
           ?list(2,SY(cxtoken),cxobject_id(token))
           :list(11,SY(token),
                 KW(id),cxobject_id(token),
                 KW(kind),list(2,SY(quote),token_kind(token)),
                 KW(spelling),token_spelling(token,tu),
                 KW(location),token_location(token,tu),
                 KW(range),token_range(token,tu)));}


id translation_unit_sexp(id tu){
    return(nil);}

id cursor_translation_unit(id cursor){
    CXTranslationUnit cxtu=clang_Cursor_getTranslationUnit(unbox_cursor(cursor));
    return(cxtu?translation_unit(cxtu):nil);}

id cursor_sexp(id object){
    CXCursor cxcursor=unbox_cursor(object);
    if(clang_Cursor_isNull(cxcursor)){
        return(nil);}
    int kind=clang_getCursorKind(cxcursor);
    if((CXCursor_FirstInvalid<=kind) and (kind<=CXCursor_LastInvalid)){
        return(cons(cursorSymbol(kind),nil));}
    id tu=cursor_translation_unit(object);
    id range=cursor_range(object);
    id token_kind=cxobject_token_kind(range);
    id token_spelling=cxobject_token_spelling(range);
    id result=nconc(16,
                    list(5,cursorSymbol(kind),
                           KW(spelling),cxstring(clang_getCursorSpelling(cxcursor)),
                           KW(usr),cxstring(clang_getCursorUSR(cxcursor))),
                    (null(token_kind)?nil:list(2,KW(token-kind),list(2,SY(quote),token_kind))),
                    ((null(token_kind) and null(token_spelling) and not(null(cxobject_token(object))))?list(2,KW(token),token_sexp(cxobject_token(object),tu)):nil),
                    (null(token_spelling)?nil:list(2,KW(token-spelling),token_spelling)),
                    (clang_isDeclaration(kind)?list(2,KW(is-declaration),t):nil),
                    (clang_isCursorDefinition(cxcursor)?list(2,KW(is-definition),t):nil),
                    (clang_isReference(kind)?list(2,KW(is-reference),t):nil),
                    (clang_isExpression(kind)?list(2,KW(is-expression),t):nil),
                    (clang_isStatement(kind)?list(2,KW(is-statement),t):nil),
                    (clang_isAttribute(kind)?list(2,KW(is-attribute),t):nil),
                    (clang_isInvalid(kind)?list(2,KW(is-invalid),t):nil),
                    (clang_isTranslationUnit(kind)?list(2,KW(is-translation-unit),t):nil),
                    (clang_isPreprocessing(kind)?list(2,KW(is-preprocessing),t):nil),
                    (clang_isUnexposed(kind)?list(2,KW(is-unexposed),t):nil),
                    ((CXLinkage_Invalid==clang_getCursorLinkage(cxcursor))
                     ?nil
                     :list(2,KW(linkage),cursorLinkage(clang_getCursorLinkage(cxcursor)))),
                    ((CXLanguage_Invalid==clang_getCursorLanguage(cxcursor))
                     ?nil
                     :list(2,KW(language),cursorLanguageKind(clang_getCursorLanguage(cxcursor)))),
                    (null(platform_availability(cxcursor))?nil:list(2,KW(platform-availability),platform_availability(cxcursor))),
                    list(4,
                         KW(location),location(clang_getCursorLocation(cxcursor)),
                         KW(range),range));
    if(not(null(tu))){
        CXTranslationUnit cxtu=unbox_translation_unit(tu);
        CXCursor tucursor=clang_getTranslationUnitCursor(cxtu);
        if(not(clang_Cursor_isNull(tucursor))){
            NCONCF2(result,KW(translation-unit),cursor(tucursor));}}
    CXCursor separent=clang_getCursorSemanticParent(cxcursor);
    if(not(clang_Cursor_isNull(separent))){
        NCONCF2(result,KW(semantic-parent),cursor(separent));}
    CXCursor leparent=clang_getCursorLexicalParent(cxcursor);
    if(not(clang_Cursor_isNull(leparent))){
        NCONCF2(result,KW(lexical-parent),cursor(leparent));}
    // clang_getOverriddenCursors(cxcursor,&overridden,&num_overridden);
    // clang_disposeOverriddenCursors(overridden);
    CXFile includedFile=clang_getIncludedFile(cxcursor);
    if(includedFile){
        NCONCF2(result,KW(included-file),cxstring(clang_getFileName(includedFile)));}
    if(clang_isDeclaration(kind)){
        NCONCF2(result,KW(objc-type-encoding),cxstring(clang_getDeclObjCTypeEncoding(cxcursor)));}
    CXType tipe=clang_getCursorType(cxcursor);
    if(CXType_Invalid!=tipe.kind){
        NCONCF(result,list(2,KW(type),type(tipe)));}
    CXType underType=clang_getTypedefDeclUnderlyingType(cxcursor);
    if(CXType_Invalid!=underType.kind){
        NCONCF(result,list(2,KW(underlying-type),type(underType)));}
    CXType enumType=clang_getEnumDeclIntegerType(cxcursor);
    if(CXType_Invalid!=enumType.kind){
        NCONCF(result,list(2,KW(enum-type),type(enumType)));
        switch(enumType.kind){
          case CXType_Char_U:
          case CXType_UChar:
          case CXType_UShort:
          case CXType_UInt:
          case CXType_ULong:
          case CXType_ULongLong:
          case CXType_UInt128:{
              unsigned long long uEnumConstant=clang_getEnumConstantDeclUnsignedValue(cxcursor);
              NCONCF(result,list(2,KW(unsigned-enum-constant),integer(uEnumConstant)));
              break;}
          default:{
              long long enumConstant=clang_getEnumConstantDeclValue(cxcursor);
              NCONCF2(result,KW(enum-constant),integer(enumConstant));
              break;}}}
    // Not declared:
    /* int fieldBitWidth=clang_getFieldDeclBitWidth(cxcursor); */
    /* if(0<=fieldBitWidth){ */
    /*     NCONCF2(result,KW(field-bit-width),integer(fieldBitWidth));} */
    CXType outletType=clang_getIBOutletCollectionType(cxcursor);
    if(CXType_Invalid!=outletType.kind){
        NCONCF2(result,KW(outletType),type(outletType));}
    CXType resultType=clang_getCursorResultType(cxcursor);
    if(CXType_Invalid!=resultType.kind){
        NCONCF2(result,KW(result-type),type(resultType));}
    int numArguments=clang_Cursor_getNumArguments(cxcursor);
    if(0<=numArguments){
        id args=nil;
        for(int i=0;i<numArguments;INCF(i)){
            PUSH(cursor(clang_Cursor_getArgument(cxcursor,i)),args);}
        NCONCF(result,list(2,KW(arguments),cons(SY(list),nreverse(args))));}
    unsigned numOver=clang_getNumOverloadedDecls(cxcursor);
    if(0<numOver){
        id overdecls=nil;
        for(unsigned i=0;i<numOver;INCF(i)){
            PUSH(cursor(clang_getOverloadedDecl(cxcursor,i)),overdecls);}
        NCONCF2(result,KW(overloaded-declarations),cons(SY(list),overdecls));}
    // CXString clang_getCursorUSR(CXCursor);
    // CXString clang_constructUSR_ObjCClass(const char *class_name);
    // CXString clang_constructUSR_ObjCCategory(const char *class_name,const char *category_name);
    // CXString clang_constructUSR_ObjCProtocol(const char *protocol_name);
    // CXString clang_constructUSR_ObjCIvar(const char *name,CXString classUSR);
    // CXString clang_constructUSR_ObjCMethod(const char *name,unsigned isInstanceMethod,CXString classUSR);
    CXCursor referenced=clang_getCursorReferenced(cxcursor);
    if(not(clang_Cursor_isNull(referenced))){
        NCONCF(result,list(2,KW(referenced),cursor(referenced)));}
    CXCursor definition=clang_getCursorDefinition(cxcursor);
    if(not(clang_Cursor_isNull(definition))){
        NCONCF(result,list(2,KW(definition),cursor(definition)));}
    CXCursor canonical=clang_getCanonicalCursor(cxcursor);
    if(not(clang_Cursor_isNull(canonical))){
        NCONCF(result,list(2,KW(canonical),cursor(canonical)));}
    NCONCF(result,list(2,KW(children),cons(SY(list),cursor_children(cursor(cxcursor)))));
    if(CXCursor_CXXAccessSpecifier==kind){
        if(clang_isVirtualBase(cxcursor)){
            NCONCF2(result,KW(virtual-base),t);}}
    if((CXCursor_CXXBaseSpecifier==kind) or (CXCursor_CXXAccessSpecifier==kind)){
        NCONCF2(result,KW(access-specifier),accessSpecifier(clang_getCXXAccessSpecifier(cxcursor)));}
    return(result);}

id cxobjects_in_sexp(id sexp){
    switch(type_of(sexp)){
      case ot_CXType: // fall thru
      case ot_CXToken:
      case ot_CXCursor:
      case ot_CXSourceRange:
      case ot_CXSourceLocation:
      case ot_CXTranslationUnit:
          return(cons(sexp,nil));
      case ot_cons:
          return(nconc(2,
                       cxobjects_in_sexp(car(sexp)),
                       cxobjects_in_sexp(cdr(sexp))));
      case ot_vector:
          if(ot_t==vector_element_type(sexp)){
              id result=nil;
              DOTIMES(i,length(sexp),
                      { NCONCF(result,cxobjects_in_sexp(vector_get(sexp,i))); });
              return(result);}
          else{
              return(nil);}
      default:
          return(nil);}}


void cxobjects_compute_sexps(id cxobject){
    id sexp=nil;
    switch(type_of(cxobject)){
      case ot_CXType:            sexp=type_sexp(cxobject);             break;
      case ot_CXToken:           sexp=token_sexp(cxobject,nil);        break;
      case ot_CXCursor:          sexp=cursor_sexp(cxobject);           break;
      case ot_CXSourceRange:     sexp=range_sexp(cxobject);            break;
      case ot_CXSourceLocation:  sexp=location_sexp(cxobject);         break;
      case ot_CXTranslationUnit: sexp=translation_unit_sexp(cxobject); break;
      default: ERROR("Unexpected object of type %s, instead of a CX object.",
                     type_name(type_of(cxobject)));}
    cxobject_set_sexp(cxobject,sexp);
    DOLIST(child,cxobjects_in_sexp(sexp),
           {if(not(cxobject_sexp(child))){
                   cxobjects_compute_sexps(child);}});}


void test_all(void);


id replace_cxobject_references(id sexp){
    switch(type_of(sexp)){
      case ot_CXType:
          return(list(2,SY(cxtype),cxobject_id(sexp)));
      case ot_CXToken:
          return(list(2,SY(cxtoken),cxobject_id(sexp)));
      case ot_CXCursor:
          return(list(2,SY(cxcursor),cxobject_id(sexp)));
      case ot_CXSourceRange:
          return(list(2,SY(cxsourcerange),cxobject_id(sexp)));
      case ot_CXSourceLocation:
          return(list(2,SY(cxsourcelocation),cxobject_id(sexp)));
      case ot_CXTranslationUnit:
          return(list(2,SY(cxtranslationunit),cxobject_id(sexp)));
      case ot_cons:
          return(cons(replace_cxobject_references(car(sexp)),
                      replace_cxobject_references(cdr(sexp))));
      case ot_vector:
          if(ot_t==vector_element_type(sexp)){
              int len=length(sexp);
              id result=make_vector(ot_t,len,len,0);
              DOTIMES(i,len,{vector_set(result,i,replace_cxobject_references(vector_get(sexp,i)));});
              return(result);}
          else{
              return(sexp);}
      default:
          return(sexp);}}


void print_hashtable_entry(id key,id value,void* data){
    id stream=data;
    print(list(3,key,SY(-->),value),stream);}


void print_cursor_sexp(id cxobject,id value,void* data){
    id table=data;
    id sexp=cxobject_sexp(cxobject);
    print(list(2,cxobject_id(cxobject),replace_cxobject_references(sexp)),nil);
    /* id token=cxobject_token(cxobject); */
    /* if(sexp){ */
    /*     if(cursorp(cxobject) and token){ */
    /*         print(list(3,cxobject_id(cxobject),replace_cxobject_references(sexp), */
    /*                    token_sexp(token,cursor_translation_unit(cxobject))),nil);} */
    /*     else{ */
    /*         print(list(2,cxobject_id(cxobject),replace_cxobject_references(sexp)),nil);}} */}


bool check_for_errors(id tu){
    DOTIMES(i,clang_getNumDiagnostics(unbox_translation_unit(tu)),
            {CXDiagnostic diag=clang_getDiagnostic(unbox_translation_unit(tu),i);
             if(CXDiagnostic_Error<=clang_getDiagnosticSeverity(diag)){
                 CXString diagstr=clang_formatDiagnostic(diag,clang_defaultDiagnosticDisplayOptions());
                 fprintf(stderr,"%s\n",clang_getCString(diagstr));
                 clang_disposeString(diagstr);
                 clang_disposeDiagnostic(diag);
                 return(1);}
             clang_disposeDiagnostic(diag);});
    return(0);}


int main(int argc,const char* const* argv){
    conversion_initialize();
    print_circle=t;
    const char* pname=argv[0];
    id args=argv_to_list(argv);
    POP(args);
    if(equal(first(args),string("--test"))){
        POP(args);
        test_all();
        if(null(args)){
            exit(0);}}
    else if(equal(first(args),string("--help"))){
        printf("%s usage\n",pname);
        printf("%s --help | --test | sourcefile.c {clang options}\n",pname);}
    if(null(args)){
        ERROR("Command %s is missing a source file argument.",pname);
        return(1);}
    const char* sourceFile=unbox_string(POP(args));
    id includes=list(1,string("-I/opt/llvm/lib/clang/3.3/include"));
    const char* const* subArgv=list_to_argv(append(2,includes,args));
    int subArgc=argv_count(subArgv);
    CXIndex idx=clang_createIndex(0,1);
    id tu=translation_unit(clang_createTranslationUnitFromSourceFile(idx,sourceFile,subArgc,subArgv,0,0));
    if(0==unbox_translation_unit(tu)){
        clang_disposeIndex(idx);
        ERROR("%s: cannot create the translation unit.",pname);}
    if(check_for_errors(tu)){
        goto teardown_translation_unit;}

    id tucu=cursor(clang_getTranslationUnitCursor(unbox_translation_unit(tu)));
    id range=cursor_range(tucu);
    CXToken* tokens;
    unsigned num_tokens;
    clang_tokenize(unbox_translation_unit(tu),unbox_range(range),&tokens,&num_tokens);
    if(check_for_errors(tu)){
        goto teardown_tokens;}

    CXCursor* cursors=memory_allocate(__FUNCTION__,sizeof(*cursors),num_tokens);
    clang_annotateTokens(unbox_translation_unit(tu),tokens,num_tokens,cursors);
    if(check_for_errors(tu)){
        goto teardown_tokens;}

    DOTIMES(i,num_tokens,
            {id tk=token(tokens[i]);
             id tr=token_range(tk,tu);
             id cu=cursor(cursors[i]);
             cxobject_set_sexp(tk,token_sexp(tk,tu));
             cxobject_set_token(tr,tk);
             cxobject_set_token_info(tr,
                                     tokenSymbol(clang_getTokenKind(tokens[i])),
                                     cxstring(clang_getTokenSpelling(unbox_translation_unit(tu),tokens[i])));
             cxobject_set_token(cu,tk);
             cxobject_set_token_info(cu,
                                     tokenSymbol(clang_getTokenKind(tokens[i])),
                                     cxstring(clang_getTokenSpelling(unbox_translation_unit(tu),tokens[i])));
            });
    cxobjects_compute_sexps(tucu);
    princ(string(";; -*- mode:lisp;coding:iso-8859-1 -*-"),nil); terpri(nil);
    prin1(list(2,SY(clang-version),cxstring(clang_getClangVersion())),nil); terpri(nil);
    prin1(list(2,SY(cxcursor),cxobject_id(tucu)),nil);
    hashtable_map(conversion_object_info,print_cursor_sexp,conversion_object_info);
    terpri(nil);
    terpri(nil);
    fflush(stdout);

teardown_tokens:
    clang_disposeTokens(unbox_translation_unit(tu),tokens,num_tokens);
teardown_translation_unit:
    clang_disposeTranslationUnit(unbox_translation_unit(tu));
    clang_disposeIndex(idx);
    return(0);}



//// tests

int test_primes[]={
    2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61,
    67, 71, 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, 127, 131, 137,
    139, 149, 151, 157, 163, 167, 173, 179, 181, 191, 193, 197, 199, 211,
    223, 227, 229, 233, 239, 241, 251, 257, 263, 269, 271, 277, 281, 283,
    293, 307, 311, 313, 317, 331, 337, 347, 349, 353, 359, 367, 373, 379,
    383, 389, 397, 401, 409, 419, 421, 431, 433, 439, 443, 449, 457, 461,
    463, 467, 479, 487, 491, 499, 503, 509, 521, 523, 541, 547, 557, 563,
    569, 571, 577, 587, 593, 599, 601, 607, 613, 617, 619, 631, 641, 643,
    647, 653, 659, 661, 673, 677, 683, 691, 701, 709, 719, 727, 733, 739,
    743, 751, 757, 761, 769, 773, 787, 797, 809, 811, 821, 823, 827, 829,
    839, 853, 857, 859, 863, 877, 881, 883, 887, 907, 911, 919, 929, 937,
    941, 947, 953, 967, 971, 977, 983, 991, 997, 1009, 1013, 1019, 1021};


int test_count=0;
int test_success=0;
int test_failure=0;

#define TEST_BEGIN()                                                    \
    do{                                                                 \
        INCF(test_count);                                               \
        printf("%-40s ",__FUNCTION__);                                  \
        fflush(stdout);                                                 \
    }while(0)

void SUCCESS(const char* fname){
    INCF(test_success);
    printf("\r%-40s [OK]\n",fname);}

void FAILURE(const char* fname){
    INCF(test_failure);
    printf("\r%-40s [KO]\n",fname);}

void TOTALS(const char* fname){
    DECF(test_count);
    printf("\r%-40s     %4d success",fname,test_success);
    printf("\n%-40s     %4d failure",fname,test_failure);
    printf("\n%-40s     %4d total",fname,test_count);
    printf("\n%-40s [%s]\n",fname,(0==test_failure)?"OK":"KO");}

#define TEST_END(HOW)                                                   \
    do{                                                                 \
       HOW(__FUNCTION__);                                               \
       fflush(stdout);                                                  \
    }while(0)

void test_compute_primes_to(void){
    TEST_BEGIN();
    int count=sizeof(test_primes)/sizeof(test_primes[0]);
    id primes=compute_primes_to(1024);
    assert(vector_length(primes)==count);
    for(int i=0;i<count;INCF(i)){
        assert(vector_get_int(primes,i)==test_primes[i]);}
    TEST_END(SUCCESS);}

void test_ceiling_to_nearest_prime(void){
    TEST_BEGIN();
    int count=sizeof(test_primes)/sizeof(test_primes[0]);
    for(int i=1;i<count;INCF(i)){
        int n=test_primes[i]-1;
        int ceiling=ceiling_to_nearest_prime(n);
        unless_assert(ceiling==test_primes[i],fprintf(stderr,"n=%d, expected=%d, got=%d\n",n,test_primes[i],ceiling););}
    TEST_END(SUCCESS);}

void test_box(void){
    TEST_BEGIN();
    CXCursor c=clang_getNullCursor();
    id bc=box(ot_CXCursor,c);
    assert(ot_CXCursor==type_of(bc));
    assert(clang_Cursor_isNull(bc->value.cursor));

    id bi=box(ot_int,42);
    assert(ot_int==type_of(bi));
    assert(42==bi->value.integer);

    id bx=box(ot_char,'a');
    assert(ot_char==type_of(bx));
    assert('a'==bx->value.character);

    cons_t* k=make_cons_t(bi,bx);
    id bk=box(ot_cons,k);
    assert(ot_cons==type_of(bk));
    assert(k==bk->value.cons);

    vector_t* v=unbox_vector(make_vector(ot_int,4,0,0));
    id bv=box(ot_vector,v);
    assert(ot_vector==type_of(bv));
    assert(v==bv->value.vector);

    hashtable_t* h=unbox_hashtable(make_hashtable(42));
    id bh=box(ot_hashtable,h);
    assert(ot_hashtable==type_of(bh));
    assert(h==bh->value.hashtable);
    TEST_END(SUCCESS);}

void test_cons(void){
    TEST_BEGIN();
    assert(null(nil));
    // cons
    id c=cons(integer(42),nil);
    assert(ot_cons==type_of(c));
    assert(ot_int==type_of(car(c)));
    assert(42==unbox_integer(car(c)));
    assert(null(cdr(c)));
    // setcdr
    setcdr(c,character('B'));
    assert(ot_cons==type_of(c));
    assert(ot_int==type_of(car(c)));
    assert(42==unbox_integer(car(c)));
    assert(ot_char==type_of(cdr(c)));
    assert('B'==unbox_character(cdr(c)));
    // setcar
    id nc=cons(nil,nil);
    setcar(c,nc);
    assert(ot_cons==type_of(c));
    assert(nc==car(c));
    assert(ot_char==type_of(cdr(c)));
    assert('B'==unbox_character(cdr(c)));
    TEST_END(SUCCESS);}

void test_list(void){
    TEST_BEGIN();
    // list 0
    id l=list(0);
    assert(null(l));
    // list 1
    l=list(1,integer(42));
    assert(consp(l));
    assert(equal(integer(42),car(l)));
    assert(null(cdr(l)));
    // list 2
    l=list(2,integer(33),integer(42));
    assert(consp(l));
    assert(equal(integer(33),car(l)));
    assert(equal(integer(42),car(cdr(l))));
    assert(null(cdr(cdr(l))));
    // list 3
    l=list(3,integer(24),integer(33),integer(42));
    assert(consp(l));
    assert(equal(integer(24),car(l)));
    assert(equal(integer(33),car(cdr(l))));
    assert(equal(integer(42),car(cdr(cdr(l)))));
    assert(null(cdr(cdr(cdr(l)))));
    TEST_END(SUCCESS);}

void test_reverse(void){
    TEST_BEGIN();
    // list 0
    id l=list(0);
    id r=reverse(l);
    assert(null(r));
    // list 1
    l=list(1,integer(42));
    r=reverse(l);
    assert(consp(r));
    assert(equal(integer(42),car(r)));
    assert(null(cdr(r)));
    assert(equal(l,r));
    // list 2
    l=list(2,integer(33),integer(42));
    r=reverse(l);
    assert(consp(r));
    assert(equal(integer(42),car(r)));
    assert(equal(integer(33),car(cdr(r))));
    assert(null(cdr(cdr(r))));
    // list 3
    l=list(3,integer(24),integer(33),integer(42));
    r=reverse(l);
    assert(consp(r));
    assert(equal(integer(42),car(r)));
    assert(equal(integer(33),car(cdr(r))));
    assert(equal(integer(24),car(cdr(cdr(r)))));
    assert(null(cdr(cdr(cdr(r)))));
    TEST_END(SUCCESS);}

void test_revappend(void){
    TEST_BEGIN();
    // list 0,2
    id l=list(0);
    id z=list(2,integer(3),integer(4));
    id r=revappend(l,z);
    assert(equal(r,z));
    // list 2,2
    l=list(2,integer(2),integer(1));
    r=revappend(l,z);
    assert(consp(r));
    assert(equal(r,list(4,integer(1),integer(2),integer(3),integer(4))));
    // list 3,0
    l=list(3,integer(24),integer(33),integer(42));
    r=revappend(l,nil);
    assert(equal(r,reverse(l)));
    TEST_END(SUCCESS);}

void dump_hashtable(id table){
    fprintf(stderr,"size             = %d\n",hashtable_size(table));
    fprintf(stderr,"count            = %d\n",hashtable_count(table));
    fprintf(stderr,"rehash_size      = %f\n",hashtable_rehash_size(table));
    fprintf(stderr,"rehash_threshold = %f\n",hashtable_rehash_threshold(table));}

void test_hashtable(void){
    TEST_BEGIN();
    id table=make_hashtable(3);
    assert(0==hashtable_count(table));
    assert(3==hashtable_size(table));
    TEST_END(SUCCESS);}

void test_hashtable_set_grow(void){
    TEST_BEGIN();
    id table=make_hashtable(3);
    assert(0==hashtable_count(table));
    assert(3==hashtable_size(table));
    // hash 1
    hashtable_set(table,integer(65),character('A'));
    assert(1==hashtable_count(table));
    assert(3==hashtable_size(table));
    assert(equal(character('A'),hashtable_get(table,integer(65))));
    // hash 2
    hashtable_set(table,integer(66),character('B'));
    assert(2==hashtable_count(table));
    assert(3==hashtable_size(table));
    assert(equal(character('B'),hashtable_get(table,integer(66))));
    // hash 3
    hashtable_set(table,integer(67),character('C'));
    assert(3==hashtable_count(table));
    assert(5==hashtable_size(table));
    assert(equal(character('C'),hashtable_get(table,integer(67))));
    TEST_END(SUCCESS);}

void test_hashtable_reset(void){
    TEST_BEGIN();
    id table=make_hashtable(3);
    assert(0==hashtable_count(table));
    assert(3==hashtable_size(table));
    // hash 1
    hashtable_set(table,integer(65),character('A'));
    assert(1==hashtable_count(table));
    assert(3==hashtable_size(table));
    assert(equal(character('A'),hashtable_get(table,integer(65))));
    // hash 2
    hashtable_set(table,integer(66),character('B'));
    assert(2==hashtable_count(table));
    assert(3==hashtable_size(table));
    assert(equal(character('B'),hashtable_get(table,integer(66))));
    // hash 3
    hashtable_set(table,integer(65),character('Z'));
    assert(2==hashtable_count(table));
    assert(3==hashtable_size(table));
    assert(equal(character('Z'),hashtable_get(table,integer(65))));
    // hash 4
    hashtable_set(table,integer(66),character('Y'));
    assert(2==hashtable_count(table));
    assert(3==hashtable_size(table));
    assert(equal(character('Y'),hashtable_get(table,integer(66))));
    TEST_END(SUCCESS);}

void test_hashtable_map_function(id key,id value,void* data){
    char* hits=data;
    assert(ot_int==type_of(key));
    assert(ot_char==type_of(value));
    assert(unbox_integer(key)==unbox_character(value));
    hits[unbox_integer(key)]=unbox_character(value);}

void test_hashtable_map(void){
    TEST_BEGIN();
    id table=make_hashtable(3);
    assert(0==hashtable_count(table));
    assert(3==hashtable_size(table));
    for(int i=65;i<95;INCF(i)){
        hashtable_set(table,integer(i),character(i));}
    char hits[128]={0};
    hashtable_map(table,test_hashtable_map_function,hits);
    for(int i=0;i<128;INCF(i)){
        if((i<65) or (95<=i)){
            assert(0==hits[i]);}
        else{
            assert(i==hits[i]);}}
    TEST_END(SUCCESS);}

void test_hashtable_remove_function(id key,id value,void* data){
    id table=data;
    assert(ot_int==type_of(key));
    assert(ot_char==type_of(value));
    assert(unbox_integer(key)==unbox_character(value));
    int count=hashtable_count(table);
    assert(0<count);
    hashtable_remove(table,key);
    assert(hashtable_count(table)==count-1);}

void test_hashtable_fail_function(id key,id value,void* data){
    assert(false);}

void test_hashtable_remove(void){
    TEST_BEGIN();
    id table=make_hashtable(3);
    assert(0==hashtable_count(table));
    assert(3==hashtable_size(table));
    for(int i=65;i<95;INCF(i)){
        hashtable_set(table,integer(i),character(i));}
    int size=hashtable_size(table);
    hashtable_map(table,test_hashtable_remove_function,table);
    assert(hashtable_size(table)==size);
    assert(hashtable_count(table)==0);
    hashtable_map(table,test_hashtable_fail_function,0);
    TEST_END(SUCCESS);}

void test_equal(void){
    TEST_BEGIN();
    id a=integer(42);
    id b=integer(42);
    id c=integer(0);
    id k=cons(integer(1),integer(2));
    id l=cons(integer(1),integer(2));
    id m=cons(integer(42),integer(0));
    id u=vector(5,car(k),cdr(k),a,b,c);
    id v=vector(5,car(k),cdr(k),a,b,c);
    id w=vector(5,a,b,c,a,b);
    id x=vector(6,a,b,c,a,b,c);
    id h=make_hashtable(7);
    hashtable_set(h,a,a);
    hashtable_set(h,c,b);
    id p=make_hashtable(3);
    hashtable_set(h,a,t);
    hashtable_set(h,c,t);
    id q=make_hashtable(7);
    hashtable_set(h,a,t);
    hashtable_set(h,b,t);

         /* (let* ((o '(nil a b c k l m u v w x h p q)) */
         /*        (a 42) */
         /*        (b 42) */
         /*        (c 0) */
         /*        (k (cons 1 2)) */
         /*        (l (cons 1 2)) */
         /*        (m (cons 42 0)) */
         /*        (u (vector (car k) (cdr k) a b c)) */
         /*        (v (vector (car k) (cdr k) a b c)) */
         /*        (w (vector a b c a b)) */
         /*        (x (vector a b c a b c)) */
         /*        (h (make-hash-table)) */
         /*        (p (make-hash-table)) */
         /*        (q (make-hash-table))) */
         /*   (declare (special a b c k l m u v w x h p q)) */
         /*   (setf (gethash a h) a */
         /*         (gethash c h) b */
         /*         (gethash a p) t */
         /*         (gethash c p) t */
         /*         (gethash a q) t */
         /*         (gethash b q) t) */
         /*   (format t "*~(~)/~%") */
         /*   (dolist (v1 o) */
         /*     (dolist (v2 o) */
         /*       (if (equal (symbol-value v1) (symbol-value v2)) */
         /*           (format t"assert(equal(~a,~a));~%" v1 v2) */
         /*           (format t "assert(not(equal(~a,~a)));~%" v2 v1))))) */

    assert(equal(nil,nil));
    assert(not(equal(a,nil)));
    assert(not(equal(b,nil)));
    assert(not(equal(c,nil)));
    assert(not(equal(k,nil)));
    assert(not(equal(l,nil)));
    assert(not(equal(m,nil)));
    assert(not(equal(u,nil)));
    assert(not(equal(v,nil)));
    assert(not(equal(w,nil)));
    assert(not(equal(x,nil)));
    assert(not(equal(h,nil)));
    assert(not(equal(p,nil)));
    assert(not(equal(q,nil)));
    assert(not(equal(nil,a)));
    assert(equal(a,a));
    assert(equal(a,b));
    assert(not(equal(c,a)));
    assert(not(equal(k,a)));
    assert(not(equal(l,a)));
    assert(not(equal(m,a)));
    assert(not(equal(u,a)));
    assert(not(equal(v,a)));
    assert(not(equal(w,a)));
    assert(not(equal(x,a)));
    assert(not(equal(h,a)));
    assert(not(equal(p,a)));
    assert(not(equal(q,a)));
    assert(not(equal(nil,b)));
    assert(equal(b,a));
    assert(equal(b,b));
    assert(not(equal(c,b)));
    assert(not(equal(k,b)));
    assert(not(equal(l,b)));
    assert(not(equal(m,b)));
    assert(not(equal(u,b)));
    assert(not(equal(v,b)));
    assert(not(equal(w,b)));
    assert(not(equal(x,b)));
    assert(not(equal(h,b)));
    assert(not(equal(p,b)));
    assert(not(equal(q,b)));
    assert(not(equal(nil,c)));
    assert(not(equal(a,c)));
    assert(not(equal(b,c)));
    assert(equal(c,c));
    assert(not(equal(k,c)));
    assert(not(equal(l,c)));
    assert(not(equal(m,c)));
    assert(not(equal(u,c)));
    assert(not(equal(v,c)));
    assert(not(equal(w,c)));
    assert(not(equal(x,c)));
    assert(not(equal(h,c)));
    assert(not(equal(p,c)));
    assert(not(equal(q,c)));
    assert(not(equal(nil,k)));
    assert(not(equal(a,k)));
    assert(not(equal(b,k)));
    assert(not(equal(c,k)));
    assert(equal(k,k));
    assert(equal(k,l));
    assert(not(equal(m,k)));
    assert(not(equal(u,k)));
    assert(not(equal(v,k)));
    assert(not(equal(w,k)));
    assert(not(equal(x,k)));
    assert(not(equal(h,k)));
    assert(not(equal(p,k)));
    assert(not(equal(q,k)));
    assert(not(equal(nil,l)));
    assert(not(equal(a,l)));
    assert(not(equal(b,l)));
    assert(not(equal(c,l)));
    assert(equal(l,k));
    assert(equal(l,l));
    assert(not(equal(m,l)));
    assert(not(equal(u,l)));
    assert(not(equal(v,l)));
    assert(not(equal(w,l)));
    assert(not(equal(x,l)));
    assert(not(equal(h,l)));
    assert(not(equal(p,l)));
    assert(not(equal(q,l)));
    assert(not(equal(nil,m)));
    assert(not(equal(a,m)));
    assert(not(equal(b,m)));
    assert(not(equal(c,m)));
    assert(not(equal(k,m)));
    assert(not(equal(l,m)));
    assert(equal(m,m));
    assert(not(equal(u,m)));
    assert(not(equal(v,m)));
    assert(not(equal(w,m)));
    assert(not(equal(x,m)));
    assert(not(equal(h,m)));
    assert(not(equal(p,m)));
    assert(not(equal(q,m)));
    assert(not(equal(nil,u)));
    assert(not(equal(a,u)));
    assert(not(equal(b,u)));
    assert(not(equal(c,u)));
    assert(not(equal(k,u)));
    assert(not(equal(l,u)));
    assert(not(equal(m,u)));
    assert(equal(u,u));
    assert(not(equal(v,u)));
    assert(not(equal(w,u)));
    assert(not(equal(x,u)));
    assert(not(equal(h,u)));
    assert(not(equal(p,u)));
    assert(not(equal(q,u)));
    assert(not(equal(nil,v)));
    assert(not(equal(a,v)));
    assert(not(equal(b,v)));
    assert(not(equal(c,v)));
    assert(not(equal(k,v)));
    assert(not(equal(l,v)));
    assert(not(equal(m,v)));
    assert(not(equal(u,v)));
    assert(equal(v,v));
    assert(not(equal(w,v)));
    assert(not(equal(x,v)));
    assert(not(equal(h,v)));
    assert(not(equal(p,v)));
    assert(not(equal(q,v)));
    assert(not(equal(nil,w)));
    assert(not(equal(a,w)));
    assert(not(equal(b,w)));
    assert(not(equal(c,w)));
    assert(not(equal(k,w)));
    assert(not(equal(l,w)));
    assert(not(equal(m,w)));
    assert(not(equal(u,w)));
    assert(not(equal(v,w)));
    assert(equal(w,w));
    assert(not(equal(x,w)));
    assert(not(equal(h,w)));
    assert(not(equal(p,w)));
    assert(not(equal(q,w)));
    assert(not(equal(nil,x)));
    assert(not(equal(a,x)));
    assert(not(equal(b,x)));
    assert(not(equal(c,x)));
    assert(not(equal(k,x)));
    assert(not(equal(l,x)));
    assert(not(equal(m,x)));
    assert(not(equal(u,x)));
    assert(not(equal(v,x)));
    assert(not(equal(w,x)));
    assert(equal(x,x));
    assert(not(equal(h,x)));
    assert(not(equal(p,x)));
    assert(not(equal(q,x)));
    assert(not(equal(nil,h)));
    assert(not(equal(a,h)));
    assert(not(equal(b,h)));
    assert(not(equal(c,h)));
    assert(not(equal(k,h)));
    assert(not(equal(l,h)));
    assert(not(equal(m,h)));
    assert(not(equal(u,h)));
    assert(not(equal(v,h)));
    assert(not(equal(w,h)));
    assert(not(equal(x,h)));
    assert(equal(h,h));
    assert(not(equal(p,h)));
    assert(not(equal(q,h)));
    assert(not(equal(nil,p)));
    assert(not(equal(a,p)));
    assert(not(equal(b,p)));
    assert(not(equal(c,p)));
    assert(not(equal(k,p)));
    assert(not(equal(l,p)));
    assert(not(equal(m,p)));
    assert(not(equal(u,p)));
    assert(not(equal(v,p)));
    assert(not(equal(w,p)));
    assert(not(equal(x,p)));
    assert(not(equal(h,p)));
    assert(equal(p,p));
    assert(not(equal(q,p)));
    assert(not(equal(nil,q)));
    assert(not(equal(a,q)));
    assert(not(equal(b,q)));
    assert(not(equal(c,q)));
    assert(not(equal(k,q)));
    assert(not(equal(l,q)));
    assert(not(equal(m,q)));
    assert(not(equal(u,q)));
    assert(not(equal(v,q)));
    assert(not(equal(w,q)));
    assert(not(equal(x,q)));
    assert(not(equal(h,q)));
    assert(not(equal(p,q)));
    assert(equal(q,q));

    TEST_END(SUCCESS);}

void test_all(void){
    TEST_BEGIN();
    fprintf(stderr," ...\n");
    test_compute_primes_to();
    test_ceiling_to_nearest_prime();
    test_box();
    test_cons();
    test_list();
    test_reverse();
    test_revappend();
    test_hashtable();
    test_hashtable_set_grow();
    test_hashtable_reset();
    test_hashtable_map();
    test_hashtable_remove();
    test_equal();
    TEST_END(TOTALS);}

//// THE END ////
ViewGit