void TRAN_FPrint2_double(char *name, int n1,int n2,double *gc)
#define gc_ref(i,j) gc[ n1*(j)+i ]
{
int i,j;
int total;
static int max=10000;
FILE *fp;
total=0;
if ( (fp=fopen(name,"w"))==NULL) {
printf("can not open %s\nexit\n",name);
return;
}
fprintf(fp,"TRAN_FPrint2_double <%s> n=%d %d\n",name,n1,n2);
for (j=0;j<n2;j++) {
for (i=0;i<n1;i++) {
if (fabs(gc_ref(i,j)) > eps) {
fprintf(fp,"%d %d %le\n", i,j, gc_ref(i,j));
total++;
if ( total >max ){
fprintf(fp,"# of print >max\n");
return;
}
}
}
}
fclose(fp);
}
void TRAN_FPrint2_dcomplex(char *name, int n1,int n2,dcomplex *gc)
#define gc_ref(i,j) gc[ n1*(j)+i ]
{
int i,j;
int total;
static double eps=1.0e-30;
FILE *fp;
total=0;
if ( (fp=fopen(name,"w"))==NULL) {
printf("can not open %s\nexit\n",name);
return;
}
fprintf(fp,"TRAN_FPrint2_double <%s> n=%d %d\n",name,n1,n2);
for (j=0;j<n2;j++) {
for (i=0;i<n1;i++) {
if (fabs(gc_ref(i,j).r) > eps || fabs(gc_ref(i,j).i) > eps) {
fprintf(fp,"%d %d %30.15lf %30.15lf\n", i,j, gc_ref(i,j).r, gc_ref(i,j).i );
total++;
}
}
}
fclose(fp);
}
otag_t *
otag_object(oobject_t object)
{
otag_t *tag;
otype_t type;
orecord_t *record;
oobject_t *pointer;
if (object == null)
return (null);
switch (type = otype(object)) {
case t_basic:
record = object;
if ((tag = (otag_t *)oget_hash(tag_table, record)) == null) {
gc_ref(pointer);
onew(pointer, tag);
tag = *pointer;
tag->name = record;
tag->type = tag_basic;
tag->size = record->length;
oput_hash(tag_table, (oentry_t *)tag);
gc_dec();
}
break;
case t_record: case t_namespace:
record = object;
if ((tag = (otag_t *)oget_hash(tag_table, record)) == null) {
gc_ref(pointer);
onew(pointer, tag);
tag = *pointer;
tag->name = record;
tag->type = type == t_record ? tag_class : tag_namespace;
tag->size = sizeof(oobject_t);
oput_hash(tag_table, (oentry_t *)tag);
gc_dec();
}
break;
case t_tag:
tag = object;
break;
case t_void ... t_mpc:
tag = types[type].tag;
break;
default:
if (type & t_vector) {
type &= ~t_vector;
if (type >= t_void && type < t_mpc)
tag = types[type].vtag;
else
tag = vector_tag;
}
else
tag = auto_tag;
break;
}
return (tag);
}
void TRAN_FPrint2_binary_double(FILE *fp, int n1,int n2,double *gc)
#define gc_ref(i,j) gc[ n1*(j)+i ]
{
int i,j;
int total;
static double eps=1.0e-12;
double *v;
int iv[10];
int i0,i1;
int count;
v = (double*)malloc(sizeof(double)*n1);
i=0;
iv[i++]=n1;
iv[i++]=n2;
fwrite(iv,sizeof(int),2,fp);
for (j=0;j<n2;j++) {
i0=0;
i1=-1;
for (i=0;i<n1;i++) {
if (fabs(gc_ref(i,j)) >eps ) {
i0=i;
break;
}
}
for (i=n1-1;i>=0;i--) {
if (fabs(gc_ref(i,j)) >eps ) {
i1=i;
break;
}
}
count=0;
iv[count++]=j;
iv[count++]=i0;
iv[count++]=i1;
fwrite(iv,sizeof(int),count,fp);
#if 0
printf("%d of %d, i= [%d: %d]\n",j,n2,i0,i1);
#endif
if (i0<=i1) {
for (i=i0;i<=i1;i++) {
v[i-i0]=gc_ref(i,j);
}
fwrite(v,sizeof(double), i1-i0+1, fp);
}
}
free(v);
}
void TRAN_Print2_dx_dcomplex(char *name, int n1,int dx1, int n2,int dx2, dcomplex *gc)
#define gc_ref(i,j) gc[ n1*(j)+i ]
{
int i,j;
int total=0;
printf("TRAN_Print2_dcomplex <%s> n=%d %d\n",name,n1,n2);
for (j=0;j<n2;j+=dx2) {
for (i=0;i<n1;i+=dx1) {
if ( fabs(gc_ref(i,j).r) > eps || fabs(gc_ref(i,j).i) > eps ) {
printf("%d %d (%le %le)\n",i,j, gc_ref(i,j).r, gc_ref(i,j).i);
total++;
if (total >max) {
printf("# of print >max\n");
return;
}
}
}
}
}
void TRAN_Print2_dx_double(char *name, int n1,int dx1,int n2,int dx2,double *gc)
#define gc_ref(i,j) gc[ n1*(j)+i ]
{
int i,j;
int total=0;
printf("TRAN_Print2_double <%s> n=%d %d\n",name,n1,n2);
for (j=0;j<n2;j+=dx2) {
for (i=0;i<n1;i+=dx1) {
if (fabs(gc_ref(i,j)) > eps ) {
printf("%d %d %le\n",i,j, gc_ref(i,j));
total++;
if (total >max) {
printf("# of print >max\n");
return;
}
}
}
}
}
static otag_t *
tag_opaque(otype_t type, otagtype_t tag_type)
{
otag_t *tag;
oobject_t object;
oobject_t *pointer;
gc_enter();
gc_ref(pointer);
onew_word(pointer, type);
object = *pointer;
gc_ref(pointer);
onew(pointer, tag);
tag = *pointer;
tag->name = object;
tag->type = tag_type;
tag->size = sizeof(oobject_t);
oput_hash(tag_table, (oentry_t *)tag);
gc_leave();
return (tag);
}
otag_t *
otag_builtin(otag_t *base, ovector_t *vector, obool_t varargs)
{
otag_t *tag;
ovector_t *proto;
oint32_t length;
oint32_t offset;
osymbol_t *symbol;
oobject_t *pointer;
length = vector->offset + 1 + !!varargs;
if (length >= proto_vector->length)
orenew_vector(proto_vector, (length + 15) & ~15);
if ((proto = proto_vector->v.ptr[length]) == null) {
onew_vector(proto_vector->v.ptr + length,
t_uint8, length * sizeof(oobject_t));
proto = proto_vector->v.ptr[length];
}
proto->v.ptr[0] = base;
for (offset = 0; offset < vector->offset; offset++) {
symbol = vector->v.ptr[offset];
proto->v.ptr[offset + 1] = symbol->tag;
}
if (varargs)
proto->v.ptr[offset + 1] = varargs_tag;
if ((tag = (otag_t *)oget_hash(tag_table, proto)) == null) {
gc_ref(pointer);
onew(pointer, tag);
tag = *pointer;
onew_vector(&tag->name, t_uint8, proto->length);
memcpy(((ovector_t *)tag->name)->v.ptr, proto->v.ptr, proto->length);
tag->type = tag_function;
tag->size = sizeof(oobject_t);
tag->base = base;
oput_hash(tag_table, (oentry_t *)tag);
gc_dec();
}
return (tag);
}
static otag_t *
make_tag_vector(otag_t *base, oword_t length)
{
otag_t *tag;
oword_t size;
ovector_t *vector;
oobject_t *pointer;
/* Check for overflow */
if (length == 0)
size = 0;
else if (base->type == tag_basic) {
size = base->size * length;
if (size / base->size != length)
return (null);
}
else {
size = sizeof(oobject_t) * length;
if (size / sizeof(oobject_t) != length)
return (null);
}
gc_ref(pointer);
onew(pointer, tag);
tag = *pointer;
tag->name = base;
tag->type = tag_vector;
onew_vector(&tag->name, t_uint8, sizeof(oword_t));
vector = tag->name;
*vector->v.w = length;
tag->size = length;
tag->base = base;
oput_hash(base->data, (oentry_t *)tag);
gc_dec();
return (tag);
}
void ss::NameInfo::gc_enumerate_refs() {
Object::gc_enumerate_refs();
gc_ref(m_str);
}
otag_t *
otag_proto(otag_t *base, oast_t *decl)
{
oast_t *ast;
otag_t *tag;
oast_t *list;
oast_t *type;
oint32_t length;
oint32_t offset;
ovector_t *vector;
oobject_t *pointer;
/* remove void as single argument */
if ((ast = decl->r.ast) && ast->token == tok_type) {
tag = ast->l.value;
if (tag->type == tag_basic && tag->size == 0) {
if (ast->next)
oparse_error(ast, "'void' must be single argument");
odel_object(&decl->r.value);
}
}
for (list = decl->r.ast, length = 1; list; list = list->next, length++)
;
/* avoid allocating an object for checking */
if (length >= proto_vector->length)
orenew_vector(proto_vector, (length + 15) & ~15);
if ((vector = proto_vector->v.ptr[length]) == null) {
onew_vector(proto_vector->v.ptr + length,
t_uint8, length * sizeof(oobject_t));
vector = proto_vector->v.ptr[length];
}
vector->v.ptr[0] = base;
for (list = decl->r.ast, offset = 1; list; list = list->next, offset++) {
if (list->token == tok_ellipsis) {
if (list->next)
oparse_error(list, "%A follows '...' in argument list");
tag = varargs_tag;
}
else if (list->token == tok_type)
tag = list->l.value;
else {
if (list->token != tok_declexpr)
oparse_error(list, "expecting declaration");
type = list->l.ast;
ast = list->r.ast;
assert(type->token == tok_type);
tag = otag_ast(type->l.value, &ast);
}
vector->v.ptr[offset] = tag;
}
if ((tag = (otag_t *)oget_hash(tag_table, vector)) == null) {
gc_ref(pointer);
onew(pointer, tag);
tag = *pointer;
onew_vector(&tag->name, t_uint8, vector->length);
memcpy(((ovector_t *)tag->name)->v.ptr, vector->v.ptr, vector->length);
tag->type = tag_function;
tag->size = sizeof(oobject_t);
tag->base = base;
oput_hash(tag_table, (oentry_t *)tag);
gc_dec();
}
return (tag);
}
