#DJDSTOP # /* tree building routines for declaration tree */ # # include "parm.h" # # # include # # # include # # # include "ststructs.mh" # # # include "stsizes.mh" # # # include "stptrs.mh" # # # include "stmkfields.mh" # # extern char tokenbuf[]; /* temporary string space, shared with scanner */ # # /* # * the BAD flag (Bad Allocation Debug) is used to catch usage of previously # * freed nodes. # */ # #ifdef BAD # extern boolean BADflag; # #endif # # #ifndef BAD # # # ifdef UNDEFINED # # define MINPTR 10 # /* Faster version of initfld. */ # # define initfld(pp,v) \ # if ( (*pp = v) > MINPTR) { \ # (void) lock(v); \ # } # # /* Faster version of lock */ # # define lock(p) \ # (((p) -> refcount)++, p) # # /* Faster version of unlock */ # # define unlock(p) \ # (((p) -> refcount)--, p) # # endif # # #endif # # int retaddr(); # # extern int yyvline; # # /* # * Construct a structure with kind field strkind. Set the vlineno field # * to the current value of yyvline. Fields with the corresponding bit in # * stmkfields set are set to the values of the remaining arguments. # * Other fields are initialized to NIL. # * # * The fundamental MACHINE DEPENDENCY here is that all fields must be the # * same length -- the length of a C "unsigned". # */ # # NODE *mknode( va_alist ) # va_dcl # { # va_list ap; # int strkind; # register unsigned *p; # unsigned q; # register int v; /* bit vector identifying pointer fields in strkind */ # register int i; /* bit vector identifying fields to be initialized */ # /* to the argument values. */ # NODE *result; # # # ifdef BAD # if (BADflag) # flcheck (0,0); /* Do a complete free list check */ # else # flcheck (0,1); /* Do a quick free list check */ # # endif # # va_start(ap); # strkind = va_arg(ap, int); # # p = (unsigned *)salloc(stsize[strkind] * (sizeof (NODE *))); # result = (NODE *)p; # # v = stptrs[strkind]; # i = stmkfields[strkind]; # /* p -> refcount = 0; */ # result -> kind = strkind; # result -> vlineno = yyvline; # /* adjust p, i & v to skip standard prefix. For efficiency only */ # p += SZSTANDARDPREFIX; # i <<= SZSTANDARDPREFIX; # v <<= SZSTANDARDPREFIX; # # # q = va_arg(ap, int); # while( p - (unsigned *)result < stsize[strkind] ) { # if ( i < 0 ) { # /* initialize this field */ # if( v < 0 ) { # /* store a pointer field */ # initfld( p, q ); # } else { # /* store a non-pointer field */ # *p = q; # } # q = va_arg(ap, int); # } else { # *p = NIL; # } # i <<= 1; # v <<= 1; # p++; # } # va_end(ap); # # # ifdef BAD # if (BADflag) { # diagmsg("mknode: addr of new node=0%x, kind=%s\n", # result, kindname(strkind)); # } # # endif # # return( result ); # } # # # ifdef UNDEFINED # /* # * vfree(p) # * # * if *p's reference count is zero, # * free *p # * decrement reference counts of descendants # * call self recursively on descendants # */ # # # define MIN_PTR 10 /* lower limit for real pointers. lower values */ # /* have special significance. */ # # vfree(p) # int *p; # { # register int size; # register int v; /* bit vector identifying pointers */ # register unsigned *q; # # # ifdef BAD # if (BADflag) # flcheck (0,0); /* Do a complete free list check */ # else # flcheck (0,1); /* Do a quick free list check */ # # endif # # if ( p == NIL ) return; # # if ( !is_refd(p) ) { # /* call vfree for each child */ # if (( p -> kind) == LISTHEADER ) { # /* traverse list of descendants */ # maplist(e, p, { # if( !is_refd(unlock(e)) ) # vfree(e); # } ); # /* now free the cons nodes */ # { ConsNode *c; # for ( c = p -> lh_first; c != NIL; c = cn_del_hd(c) ); # } # } # else { /* use stptrs to find the children */ # v = stptrs[p -> kind]; # q = p; # while(v) { # if(v < 0 /* *q is a pointer */ && *q > MIN_PTR) { # if( !is_refd( unlock((NODE *) *q) ) ) # vfree((NODE *) *q); # } # v <<= 1; # q++; # } # } # /* deallocate storage */ # size = stsize[p -> kind]; # # ifdef BAD # if (BADflag) { # diagmsg("vfree: addr of freed node=0%x, kind=%s, retaddr=0%x\n", # p, kindname(p->kind), retaddr()); # } # # endif # sfree(p, size * sizeof(NODE *)); # } # } # # endif # # /* # * copynode(np) # * # * copy the node np; # * don't copy the children, but increment their reference counts. # * Return a pointer to the copy. # */ # # NODE * copynode(p) # register NODE *p; # { int size; # register int v; /* bit vector giving pointer fields */ # register unsigned *q; /* pointer to middle of new node */ # register unsigned *r; /* pointer to middle of original node */ # NODE * result; # # if ( is_list(p) ) # return( copylist(p) ); # size = stsize[p -> kind]; # v = stptrs[p -> kind]; # q = (unsigned *)salloc(size * sizeof(NODE *)); # result = (NODE *) q; # /* copy and adjust reference counts where necessary */ # /* q->refcount = 0; */ # result->kind = p->kind; # result->vlineno = p->vlineno; # result->pre_num = p -> pre_num; # result->post_num = p -> post_num; # q += SZSTANDARDPREFIX; # r = (unsigned *)p + SZSTANDARDPREFIX; # size -= SZSTANDARDPREFIX; # v <<= SZSTANDARDPREFIX; # while( size-- ) { # if( v < 0 ) { # /* copy a pointer */ # initfld( q, *r ); # q++; r++; # } else { # /* copy a nonpointer */ # *q++ = *r++; # } # v <<= 1; # } # # ifdef BAD # if (BADflag) { # diagmsg("copynode: addr of new node=0%x, kind=%s, retaddr=0%x\n", # result, kindname(result->kind), retaddr()); # } # # endif # return( result ); # } # # /* # * copylist(l) # * # * Make a new list which has on it the same elements (not copies) that # * are on l. # */ # LIST copylist(l) # LIST l; # { ConsNode *p; /* The first element of the constructed list. */ # register ConsNode *q; /* The last element of the constructed list. */ # # p = q = NIL; # # # ifdef DEBUG # if ( !is_list(l) ) { # dbgmsg("\ncopylist: arg not a list: l=%x\n",l); # abort(); # } # # endif # # maplist(v, l, # { if ( v == first(l) ) # p = q = cn_cons(lock(v),NIL); # else { # cn_settail(q, cn_cons(lock(v), NIL)); # q = cn_tail(q); # } # } ); # return( (LIST) mknode(LISTHEADER, p, q) ); # } # # # /* # * Used by maprlist below # */ # static void maprl1(l,fn) # ConsNode * l; # void (*fn)(); # { # if (l != NIL) { # maprl1(cn_tail(l),fn); # (*fn) (cn_head(l)); # } # } # # /* # * Apply fn to each element of the list l in reverse order # */ # void maprlist(l, fn) # LIST l; # void (*fn)(); # { # maprl1(l -> lh_first, fn); # } # # /* # * Return a pointer to a new LETTERID node with name fldname (a string table # * index). Set the id_def_found field. # */ # NODE * mkcompnm(sttptr) # unsigned sttptr; # { # register NODE * result; # result = mknode(LETTERID, sttptr); # result -> id_def_found = TRUE; # return(result); # } # # /* # * return an identifier node for an identifer with name # * consisting of string concatenated with the name of id. # * Id may not be an OPRID. # * The returned id has id_def_found set. (It is presumed to be a # * a field name.) # */ # NODE * prefix(string, id) # char * string; # NODE * id; # { # # ifdef DEBUG # if (id -> kind != LETTERID) { # dbgmsg("prefix: bad identifier node\n"); # } # # endif # strcpy(tokenbuf, string); # strcat(tokenbuf, getname(id -> id_str_table_index)); # return(mkcompnm(stt_enter(tokenbuf, strlen(tokenbuf)+1))); # } # # NODE *mknode( va_alist ) # va_dcl # { # va_list ap; # int strkind; # register unsigned *p; # unsigned q; # register int v; /* bit vector identifying pointer fields in strkind */ # register int i; /* bit vector identifying fields to be initialized */ # /* to the argument values. */ # NODE *result; # # # ifdef BAD # if (BADflag) # flcheck (0,0); /* Do a complete free list check */ # else # flcheck (0,1); /* Do a quick free list check */ # # endif # # va_start(ap); # strkind = va_arg(ap, int); # # p = (unsigned *)salloc(stsize[strkind] * (sizeof (NODE *))); # result = (NODE *)p; # # v = stptrs[strkind]; # i = stmkfields[strkind]; # /* p -> refcount = 0; */ # result -> kind = strkind; # result -> vlineno = yyvline; # /* adjust p, i & v to skip standard prefix. For efficiency only */ # p += SZSTANDARDPREFIX; # i <<= SZSTANDARDPREFIX; # v <<= SZSTANDARDPREFIX; # # # q = va_arg(ap, int); # while( p - (unsigned *)result < stsize[strkind] ) { # if ( i < 0 ) { # /* initialize this field */ # if( v < 0 ) { # /* store a pointer field */ # initfld( p, q ); # } else { # /* store a non-pointer field */ # *p = q; # } # q = va_arg(ap, int); # } else { # *p = NIL; # } # i <<= 1; # v <<= 1; # p++; # } # va_end(ap); # # # ifdef BAD # if (BADflag) { # diagmsg("mknode: addr of new node=0%x, kind=%s\n", # result, kindname(strkind)); # } # # endif # # return( result ); # } # #DJDSTART $include "defs.icn" $include "global_vars.icn" procedure mknode(va_alist) # yyvline is a global local i,arg,arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg12,arg13,arg14,arg15,arg16,ret,kind,pre_num,post_num,cn_tl_field,cn_hd_field cn_tl_field := cn_hd_field := pre_num := post_num := arg1 := arg2 := arg3 := arg4 := arg5 := arg6 := arg7 := arg8 := arg9 := arg10 := arg11 := arg12 := arg13 := nil i := 1 yyinfo("mknode va_alist") nodes_total_cnt +:= 1 nodes_made_cnt +:= 1 every (arg := !va_alist) do { case i of { 1: arg1 := arg 2: arg2 := arg 3: arg3 := arg 4: arg4 := arg 5: arg5 := arg 6: arg6 := arg 7: arg7 := arg 8: arg8 := arg 9: arg9 := arg 10: arg10 := arg 11: arg11 := arg 12: arg12 := arg 13: arg13 := arg 14: arg14 := arg 15: arg15 := arg 16: arg16 := arg default: rpt_err("mknode no of args not implemented") } i +:= 1 } case arg1 of { DECLARATION: ret := DeclarationNode(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg12,arg13,arg14,arg15,arg16,arg1,yyvline,pre_num,post_num) PARAMETER: ret := ParameterNode(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg1,yyvline,pre_num,post_num) RECORDELEMENT: ret := RElementNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num) VARSIGNATURE: ret := VarSignature(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) VALSIGNATURE: ret := ValSignature(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) FUNCSIGNATURE: ret := FSignature(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg1,yyvline,pre_num,post_num) TYPESIGNATURE: ret := TSignature(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg12,arg1,yyvline,pre_num,post_num) TSCOMPONENT: ret := TSComponentNode(arg2,arg3,arg1,yyvline,pre_num,post_num) DEFCHARSIGS: ret := DefCharSigNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num) LISTHEADER: ret := ListHeaderNode(arg2,arg3,arg1,yyvline,pre_num,post_num) SIGNATURESIG: ret := SignatureSigNode(arg2,arg3,arg1,yyvline,pre_num,post_num) BLOCKDENOTATION: ret := BlDenotationNode(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg1,yyvline) USELIST: ret := UseListNode(arg2,arg3,arg4,arg5,arg6,arg7,arg1,yyvline,pre_num,post_num) APPLICATION: ret := ApplicationNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num) ENUMERATION: ret := EnumerationNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) EXTENSION: ret := ExtensionNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num) PRODCONSTRUCTION: ret := ProductNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num) RECORDCONSTRUCTION: ret := RecordConstructionNode(arg2,arg3,arg4,arg5,arg1,yyvline,pre_num,post_num) UNIONCONSTRUCTION: ret := UnionConstructionNode(arg2,arg3,arg4,arg5,arg6,arg1,yyvline,pre_num,post_num) WITHLIST: ret := WithListNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) MODPRIMARY: ret := ModPrimaryNode(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg1,yyvline,pre_num,post_num) # looks 1 extra EXPORTLIST: ret := ExportListNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) # looks 3 extra HIDELIST: HideListNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) EXPORTELEMENT: ret := ExportElementNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) ALLCONSTANTS: ret := AllConstantsNode(arg1,yyvline,pre_num,post_num) WORDELSE: ret := WordElseNode(arg2,arg3,arg1,yyvline,pre_num,post_num) WORDCAND: ret := WordCandNode(arg1,yyvline,pre_num,post_num) WORDCOR: ret := WordCorNode(arg1,yyvline,pre_num,post_num) GUARDEDLIST: ret := GuardedListNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) LOOPDENOTATION: ret := LoopDenotationNode(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) GUARDEDELEMENT: ret := GuardedElementNode(arg2,arg3,arg1,yyvline,pre_num,post_num) OPRID: ret := OpridNode(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg1,yyvline,pre_num,post_num) LETTERID: ret := LetterId(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg1,yyvline,pre_num,post_num) QSTR: ret := QStrNode(arg2,arg3,arg4,arg5,arg6,arg7,arg1,yyvline,pre_num,post_num) UQSTR: ret := UQStrNode(arg2,arg3,arg4,arg5,arg6,arg7,arg1,yyvline,pre_num,post_num) FUNCCONSTR: ret := FConstruction(arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,arg10,arg11,arg1,yyvline,pre_num,post_num) # looks 3 extra FREEVARNODE: ret := FreeVarNodeNode(arg2,arg3,arg4,arg5,arg1,yyvline,pre_num,post_num) EXTERNDEF: ret := ExternDefNode(arg2,arg1,yyvline,pre_num,post_num) REXTERNDEF: ret := RExternDef(arg2,arg3,arg4,arg1,yyvline,pre_num,post_num) DCSEXCEPTION: ret := DcsException(arg2,arg3,arg4,arg5,arg1,yyvline,pre_num,post_num) default: rpt_err("mknode not implemented dump_info(arg1) = " || dump_info(arg1)) } rpt_node("mkode return",ret) ret.dump() return ret end # # copylist(l) # # Make a new list which has on it the same elements (not copies) that # are on l. # procedure copylist(l) local l2 l2 := copy(l) return l2 end procedure rpt_node(where,node_it) local kind initial nodeinfo("where" || repl(" ",32 - *"where") || "kind" || repl(" ",8 - *"kind") || "type(node)") kind := node_it.kind if \kind then nodeinfo(where || repl(" ",32 - *where) || kind || repl(" ",8 - *kind) || type(node_it)) else nodeinfo(where || repl(" ",32 - *where) || "nil") end # # # Return a pointer to a new LETTERID node with name fldname (a string table # index). Set the id_def_found field. # procedure mkcompnm(sttptr) local result result := mknode([LETTERID, sttptr]) result.id_def_found := TRUE; return(result) end # return an identifier node for an identifer with name # consisting of string concatenated with the name of id. # Id may not be an OPRID. # The returned id has id_def_found set. (It is presumed to be a # a field name.) # procedure prefix(string, id) local tokenbuf tokenbuf := string || getname(id.id_str_table_index) return(mkcompnm(stt_enter(tokenbuf, *tokenbuf))) end #DJDSTOP