diff options
Diffstat (limited to 'backendC/CleanCompilerSources/tcsupport_2.c')
| -rw-r--r-- | backendC/CleanCompilerSources/tcsupport_2.c | 187 |
1 files changed, 187 insertions, 0 deletions
diff --git a/backendC/CleanCompilerSources/tcsupport_2.c b/backendC/CleanCompilerSources/tcsupport_2.c new file mode 100644 index 0000000..173f6e1 --- /dev/null +++ b/backendC/CleanCompilerSources/tcsupport_2.c @@ -0,0 +1,187 @@ +/* + Version 1.2 21/01/1997 + + Author: Sjaak Smetsers +*/ + +#pragma options (!macsbug_names) + +#include "system.h" + +#include "settings.h" +#include "syntaxtr.t" +#include "comsupport.h" + +#include "sizes.h" +#include "checker.h" +#include "checksupport.h" +#include "tctypes.t" +#include "typechecker.h" +#include "typechecker2.h" +#include "typeconv.h" +#include "tcsupport.h" +#include "overloading.h" +#include "scanner.h" +#include "comparser.h" +#include "buildtree.h" + +BITVECT DetermineUniPropOfTypeCons (SymbDef typecons) +{ + if (typecons -> sdef_kind == TYPE || typecons -> sdef_kind == RECORDTYPE) + return (typecons -> sdef_type) ? typecons -> sdef_type -> type_uniprop : ALLBITSSET; + else + return (typecons -> sdef_kind == TYPESYN) ? typecons -> sdef_syn_type -> syntype_uniprop : ALLBITSSET; + +} /* DetermineUniPropOfTypeCons */ + +BITVECT DetermineConsVarsOfTypeCons (SymbDef typecons, ConsVarList * cons_vars) +{ + if (typecons -> sdef_kind == TYPE || typecons -> sdef_kind == RECORDTYPE) + { if (typecons -> sdef_type) + { * cons_vars = typecons -> sdef_type -> type_lhs -> ft_cons_vars; + return typecons -> sdef_type -> type_consvars; + } + else + { * cons_vars = NULL; + return ALLBITSCLEAR; + } + } + else if (typecons -> sdef_kind == TYPESYN) + { * cons_vars = typecons -> sdef_syn_type -> syn_lhs -> ft_cons_vars ; + return typecons -> sdef_syn_type -> syn_consvars; + } + else + { * cons_vars = NULL; + return ALLBITSCLEAR; + } + +} /* DetermineConsVarsOfTypeCons */ + +TypeCell SkipIndirectionChain (TypeCell type) +{ + MemoryCheck (type); + for (; type -> tc_kind == Indirection; type = type -> contents_indirect) + MemoryCheck (type); + return type; +} /* SkipIndirectionChain */ + +#define SubstitutedType(typeargs) ((typeargs)[-1]) + +TypeCell SkipTypeSynIndirection (TypeCell type) +{ + if (type -> tc_kind == ConstructorType && type -> tc_expanded) + { type = SubstitutedType (type -> contents_tc_args); + SkipIndirections (type); + } + return type; + +} /* SkipTypeSynIndirection */ + +void PrintNodeSymbol (Node node, int arg_nr, File file) +{ + Symbol rootsymb; + + switch (node -> node_kind) + { + case IfNode: + switch (arg_nr) + { + case 1: FPutS ("condition part of guard or if rule", file); + return; + case 2: FPutS ("then part of guard or if rule", file); + return; + case 3: FPutS ("else part of guard or if rule", file); + return; + default: FPutS ("guard or if rule", file); + return; + } + break; + case SelectorNode: + if (arg_nr == 1) + FPutS ("argument of selection", file); + else + FPutS ("selection", file); + return; + case MatchNode: + if (arg_nr == 1) + { FPutS ("rhs selection of", file); + break; + } + else + { FPutS ("rhs selection", file); + return; + } + case UpdateNode: + FPutS ("update of record", file); + break; + case NodeIdNode: + if (node -> node_node_id -> nid_ident != NULL) + { Ident id = node -> node_node_id -> nid_ident; + if (TestMark (node -> node_node_id, nid_mark2, NID_FIELD_NAME_MASK)) + { SymbDef rec_symb = (SymbDef) id -> ident_environ; + + FPrintF (file, "field %s of record %s", id -> ident_name, rec_symb -> sdef_ident -> ident_name); + } + else + FPutS (id -> ident_name, file); + } + else if (node -> node_node_id -> nid_node) + PrintNodeSymbol (node -> node_node_id -> nid_node, 0, file); + return; + default: + break; + } + + rootsymb = node -> node_symbol; + + if (rootsymb -> symb_kind == select_symb) + { if (arg_nr == 1) + { FPrintF (file, "%d-tuple selection of ", rootsymb -> symb_arity); + PrintNodeSymbol (node -> node_arguments -> arg_node, 0, file); + } + else + FPrintF (file, "selection of the %d-th argument of a %d-tuple ", node -> node_arity, rootsymb -> symb_arity); + } + else if (rootsymb -> symb_kind == apply_symb) + { if (arg_nr == 1) + PrintNodeSymbol (node -> node_arguments -> arg_node, 0, file); + else + { Node argnode; + for (arg_nr = 1, argnode = node -> node_arguments -> arg_node; + argnode -> node_kind == NormalNode && argnode -> node_symbol -> symb_kind == apply_symb; + argnode = argnode -> node_arguments -> arg_node) + arg_nr ++; + PrintNodeSymbol (argnode, arg_nr, file); + } + } + else if (rootsymb -> symb_kind == tuple_symb) + { int tup_arity = node -> node_arity; + FPutS ("(_", file); + for (tup_arity--; tup_arity > 0; tup_arity--) + FPutS (",_", file); + FPutC (')', file); + } + else + { if (arg_nr > 0) + { if (rootsymb -> symb_kind == definition && rootsymb -> symb_def -> sdef_kind == IMPRULE) + { if (arg_nr <= rootsymb -> symb_def -> sdef_nr_of_lifted_nodeids) + { Args lifted_arg; + int i; + + for (i = 1, lifted_arg = node -> node_arguments; i < arg_nr; i ++, lifted_arg = lifted_arg -> arg_next) + ; + if (lifted_arg -> arg_node -> node_kind == NodeIdNode) + FPrintF (StdError, "internal argument %s of ", lifted_arg -> arg_node -> node_node_id -> nid_ident -> ident_name); + else + FPrintF (StdError, "internal argument %d of ", arg_nr); + } + else + FPrintF (StdError, "argument %d of ", arg_nr - rootsymb -> symb_def -> sdef_nr_of_lifted_nodeids); + } + else + FPrintF (StdError, "argument %d of ", arg_nr); + } + PrintSymbol (rootsymb, file); + } + +} /* PrintNodeSymbol */ |