node lookupword(node f){
node p;
f = unpos(f);
assertpos(f->tag == unique_string_tag,f);
p = f->body.unique_string.symbol_list;
return p != NULL ? car(p) : NULL;
}
node chktype2(node e,scope v){
node f, ftype;
f = chk(e,v);
if (f == bad__K) return bad_or_undefined_T;
if (equal(f,type__K)) return type__T;
ftype = type(f);
if (ftype != type__T) {
node sym;
if (ftype != deferred__T) {
errorpos(e,"not valid type");
return NULL;
}
sym = unpos(f);
assert(issym(sym));
if (sym->body.symbol.value == NULL) {
node t = newtype(f,NULL,FALSE);
t->body.type.flags = deferred_F;
assert(issym(sym));
sym->body.symbol.value = t;
t->body.type.name = sym;
}
return sym->body.symbol.value;
}
return f; /* was totype(f) */
}
node ormembertype(node ortype, node membername) {
node m;
assert(isortype(ortype));
membername = unpos(membername);
m = ortype->body.type.commons;
while (m != NULL) {
if (equal(CAAR(m),membername)) {
node t = typeforward(CADAR(m));
return t;
}
m = CDR(m);
}
return NULL;
}
node membertype(node structtype, node membername) {
node m;
membername = unpos(membername);
if (membername == len_S) return int_T;
if (membername == type__S) return int_T;
if (istype(structtype)) m = typedeftail(structtype);
else m = CDR(structtype);
if (ispos(membername)) membername = membername->body.position.contents;
while (m != NULL) {
if (equal(CAAR(m),membername)) {
node t = typeforward(CADAR(m));
return t;
}
m = CDR(m);
}
return NULL;
}
node ExpandType(node t, node *f) {
/* t should be a type expression that might need expanding. Its expanded
form gets returned, and also put on the top of the list f
unless it's already a type or basic type */
switch(t->tag) {
case position_tag: return ExpandType(t->body.position.contents,f);
case type_tag: return t;
case symbol_tag: {
if (t->body.symbol.type == type__T) {
assert(istype(t->body.symbol.value));
return t->body.symbol.value;
}
if (t == bad__K) return bad_or_undefined_T;
assert(FALSE); return NULL;
}
case cons_tag: {
node fun = CAR(t);
if (ispos(fun)) fun = fun->body.position.contents;
t = CDR(t);
if (fun == or_K) {
/* here we should sort! */
/* we should also merge sub-or's in, and eliminate
duplicates */
/* we really only handle (or null (object)) now! */
node newN = NULL;
node mems = NULL;
while (t != NULL) {
node u = ExpandType(CAR(t),f);
push(mems,u);
t = CDR(t);
}
apply(reverse,mems);
newN = newtype(cons(fun,mems),NULL,FALSE);
push(*f,newN);
return newN;
}
else if (fun == object__K || fun == tagged_object_K /* ? */ ) {
node newN = NULL;
while (t != NULL) {
node name = CAAR(t);
node u = CADAR(t);
push(newN, list(2, unpos(name), ExpandType(u,f)));
t = CDR(t);
}
apply(reverse,newN);
newN = newtype(cons(fun,newN),NULL,FALSE);
push(*f,newN);
return newN;
}
else if (fun == array_K || fun == tarray_K) {
node newN;
newN = cons(fun,cons(ExpandType(car(t),f),cdr(t)));
newN = newtype(newN,NULL,FALSE);
*f = cons(newN,*f);
return newN;
}
else if (fun == function_S) {
node argtypes = car(t);
node rettype = cadr(t);
node newargtypes = NULL;
node newN;
while (argtypes != NULL) {
newargtypes = cons(
ExpandType(car(argtypes),f), newargtypes);
argtypes = cdr(argtypes);
}
newargtypes = reverse(newargtypes);
rettype = ExpandType(rettype,f);
newN = list(3,fun,newargtypes,rettype);
newN = newtype(newN,NULL,FALSE);
*f = cons(newN,*f);
return newN;
}
else assert(FALSE); return NULL;
}
default: assert(FALSE); return NULL;
}
}
node type(node e){ /* assume e is checked previously */
/* this returns a unique TYPE */
if (e == NULL) return void_T;
again:
switch(e->tag) {
case position_tag: e = e->body.position.contents; goto again;
case symbol_tag: return e->body.symbol.type;
case string_const_tag: /* not implemented yet */ return bad_or_undefined_T;
case char_const_tag: return char_T;
case int_const_tag: return int_T;
case double_const_tag: return double_T;
case string_tag: assert(FALSE);
case unique_string_tag: assert(FALSE); /* was return bad_or_undefined_T; */
case cons_tag: {
node h, ht;
h = unpos(CAR(e));
if (h->tag == unique_string_tag) {
if (h == equalequal__S || h == unequal_S) return bool_T;
if (h == cast__S) {
assert(istype(CADR(e)));
return cadr(e);
}
if (h == function_S) return type__T;
if (h == funcall__S || h == prefix__S || h == infix__S) {
return functionrettype(type(CADR(e)));
}
if (h == take__S) {
return membertype(type(CADR(e)),CADDR(e));
}
if (h == array_take_S) {
return arrayElementType(type(CADR(e)));
}
if (h == return_S) return returns_T;
if (h == exits_S) return exits_T;
if (h == Ccode_S) return cadr(e);
assert(FALSE);
}
ht = type(h);
if (ht == type__T) return totype(h);
if (ht == keyword_T) {
node w = ispos(h) ? h->body.position.contents : h;
if (w == block__K) return void_T;
if (w == blockn__K) {
if (length(e) < 2) return void_T;
return type(last(e));
}
if ( w == object__K || w == tagged_object_K || w == array_K || w == tarray_K || w == or_K) {
return type__T;
}
if (w == label__S) return void_T;
if (w == goto__S) return void_T;
assert(FALSE); /* there must be some other keywords! */
}
ht = ht->body.type.definition;
if (iscons(ht)) {
if (equal(CAR(ht),function_S)) {
assert(FALSE);
return caddr(ht);
}
else assert(FALSE); return NULL;
}
assert(FALSE); return NULL;
}
case type_tag: return type__T;
}
assert(FALSE);
return NULL;
}
int main(int argc, char **argv){
int i;
char *p;
GC_INIT();
::cgc1::cgc_root_t hash_bucket_root(hash_buckets);
hash_buckets=reinterpret_cast<node*>(::cgc1::cgc_malloc(sizeof(node)*7313));
progname = BaseName(argv[0]);
yyinit();
for (p=argv[0]; *p; p++) if (*p=='/') progname = p+1;
for (i=1; i<argc; i++) {
if (EQUAL == strcmp(argv[i],"--help")) {
usage();
exit(0);
}
if (EQUAL == strcmp(argv[i],"-dep")) {
stop_after_dep = TRUE;
continue;
}
if (EQUAL == strcmp(argv[i],"-cxx")) {
do_cxx = TRUE;
continue;
}
if (EQUAL == strcmp(argv[i],"-noline")) {
noline = TRUE;
continue;
}
if (EQUAL == strcmp(argv[i],"-pthreadlocal")) {
pthreadThreadLocal=TRUE;
compilerThreadLocal=FALSE;
continue;
}
if (EQUAL == strcmp(argv[i],"-typecodes")) {
printtypecodes();
return 0;
}
if (EQUAL == strcmp(argv[i],"-noarraychks")) {
arraychks = FALSE;
continue;
}
if (EQUAL == strcmp(argv[i],"-nocasechks")) {
casechks = FALSE;
continue;
}
if (EQUAL == strcmp(argv[i],"-nomacros")) {
nomacros = TRUE;
continue;
}
if (EQUAL == strcmp(argv[i],"-O")) {
arraychks = FALSE;
casechks = FALSE;
continue;
}
if (EQUAL == strcmp(argv[i],"-tabwidth")) {
i++;
if (i < argc) tabwidth = atoi(argv[i]);
continue;
}
if (EQUAL == strcmp(argv[i],"-yydebug")) {
yydebug = 1;
continue;
}
if (EQUAL == strcmp(argv[i],"-debug")) {
debug = TRUE;
continue;
}
if (EQUAL == strcmp(argv[i],"-v")) {
puts(Version);
puts(Copyright);
continue;
}
if ('-' == argv[i][0] && 'I' == argv[i][1]) {
if (argv[i][2] == 0) {
error("-I option: missing directory");
usage();
exit(1);
}
char buf[256];
strcpy(buf,sigpath);
strcat(buf,":");
strcat(buf,argv[i]+2);
sigpath = strperm(buf);
continue;
}
if ('-' == argv[i][0]) {
error("unrecognized option %s\n",argv[i]);
usage();
exit(1);
}
if ( EQUAL == strcmp(".d",tail(argv[i])) || EQUAL == strcmp(".dd",tail(argv[i])) ) {
node f;
do_this_cxx = do_cxx || EQUAL == strcmp(".dd",tail(argv[i]));
global_scope = new(struct SCOPE);
readsetup(global_scope);
targetname = newsuffixbase(argv[i],"");
f = readfile(argv[i]);
if (debug) {
char *n = newsuffixbase(argv[i],".out");
if (NULL == freopen(n,"w", stdout)) {
fatal("can't open file %s",n);
}
put("After parsing:\n");
pp(f);
fflush(stdout);
}
outfilename = newsuffixbase(argv[i], do_this_cxx ? "-tmp.cc" : "-tmp.c");
{
char *n = newsuffixbase(argv[i],".dep.tmp");
dependfile = fopen(n,"w");
if (dependfile == NULL) fatal("can't open file %s",n);
}
f = chkprogram(f);
if (debug) {
char *n = newsuffixbase(argv[i],".log");
if (NULL == freopen(n,"w", stdout)) {
fatal("can't open file %s",n);
}
pprintl(f);
}
{
node t = global_scope->signature;
char *n = newsuffixbase(argv[i],".sig.tmp");
if (NULL == freopen(n,"w", stdout)) {
fatal("can't open file %s",n);
}
printf("-- generated by %s\n\n",progname);
while (t != NULL) {
dprint(CAR(t));
put(";\n");
t = CDR(t);
}
}
if (stop_after_dep) quit();
checkfordeferredsymbols();
if (debug) {
char *n = newsuffixbase(argv[i],".sym");
if (NULL == freopen(n,"w", stdout)) {
fatal("can't open file %s",n);
}
printsymboltable();
printtypelist();
printstringlist();
}
if (n_errors > 0) {
quit();
}
if (TRUE) {
char *n = newsuffixbase(argv[i],"-exports.h.tmp");
if (NULL == freopen(n,"w", stdout)) {
fatal("can't open file %s",n);
}
printf("#ifndef %s_included\n",targetname);
printf("#define %s_included\n",targetname);
declarationsstrings = reverse(declarationsstrings);
while (declarationsstrings) {
node s = unpos(car(declarationsstrings));
assert(isstrconst(s));
put_unescape(s->body.string_const.characters);
put("\n");
declarationsstrings = cdr(declarationsstrings);
}
put(declarations_header);
/* printtypecodes(); */
cprinttypes();
put(declarations_trailer);
put("#endif\n");
}
if (TRUE) {
if (NULL == freopen(outfilename,"w", stdout)) {
fatal("can't open file %s",outfilename);
}
printf("#include \"%s\"\n",newsuffixbase(argv[i],"-exports.h"));
put(code_header);
headerstrings = reverse(headerstrings);
while (headerstrings) {
locn(car(headerstrings));
printpos();
node s = unpos(car(headerstrings));
assert(isstrconst(s));
put_unescape(s->body.string_const.characters);
put("\n");
locn(NULL);
headerstrings = cdr(headerstrings);
}
cprintsemi(f);
}
}
else {
fprintf(stderr,"unknown file type %s\n",argv[i]);
usage();
exit(1);
}
}
quit();
return 0;
}
