summaryrefslogtreecommitdiff
path: root/src/iconc/ctree.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/iconc/ctree.c')
-rw-r--r--src/iconc/ctree.c777
1 files changed, 0 insertions, 777 deletions
diff --git a/src/iconc/ctree.c b/src/iconc/ctree.c
deleted file mode 100644
index 170a631..0000000
--- a/src/iconc/ctree.c
+++ /dev/null
@@ -1,777 +0,0 @@
-/*
- * ctree.c -- functions for constructing parse trees.
- */
-#include "../h/gsupport.h"
-#include "../h/lexdef.h"
-#include "ctrans.h"
-#include "ctree.h"
-#include "csym.h"
-#include "ctoken.h"
-#include "ccode.h"
-#include "cproto.h"
-
-/*
- * prototypes for static functions.
- */
-static nodeptr chk_empty (nodeptr n);
-static void put_elms (nodeptr t, nodeptr args, int slot);
-static nodeptr subsc_nd (nodeptr op, nodeptr arg1, nodeptr arg2);
-
-/*
- * tree[1-6] construct parse tree nodes with specified values.
- * loc_model is a node containing the same line and column information
- * as is needed in this node, while parameters a through d are values to
- * be assigned to n_field[0-3]. Note that this could be done with a
- * single routine; a separate routine for each node size is used for
- * speed and simplicity.
- */
-
-nodeptr tree1(type)
-int type;
- {
- register nodeptr t;
-
- t = NewNode(0);
- t->n_type = type;
- t->n_file = NULL;
- t->n_line = 0;
- t->n_col = 0;
- t->freetmp = NULL;
- return t;
- }
-
-nodeptr tree2(type, loc_model)
-int type;
-nodeptr loc_model;
- {
- register nodeptr t;
-
- t = NewNode(0);
- t->n_type = type;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- return t;
- }
-
-nodeptr tree3(type, loc_model, a)
-int type;
-nodeptr loc_model;
-nodeptr a;
- {
- register nodeptr t;
-
- t = NewNode(1);
- t->n_type = type;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_ptr = a;
- return t;
- }
-
-nodeptr tree4(type, loc_model, a, b)
-int type;
-nodeptr loc_model;
-nodeptr a, b;
- {
- register nodeptr t;
-
- t = NewNode(2);
- t->n_type = type;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_ptr = a;
- t->n_field[1].n_ptr = b;
- return t;
- }
-
-nodeptr tree5(type, loc_model, a, b, c)
-int type;
-nodeptr loc_model;
-nodeptr a, b, c;
- {
- register nodeptr t;
-
- t = NewNode(3);
- t->n_type = type;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_ptr = a;
- t->n_field[1].n_ptr = b;
- t->n_field[2].n_ptr = c;
- return t;
- }
-
-nodeptr tree6(type, loc_model, a, b, c, d)
-int type;
-nodeptr loc_model;
-nodeptr a, b, c, d;
- {
- register nodeptr t;
-
- t = NewNode(4);
- t->n_type = type;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_ptr = a;
- t->n_field[1].n_ptr = b;
- t->n_field[2].n_ptr = c;
- t->n_field[3].n_ptr = d;
- return t;
- }
-
-nodeptr int_leaf(type, loc_model, a)
-int type;
-nodeptr loc_model;
-int a;
- {
- register nodeptr t;
-
- t = NewNode(1);
- t->n_type = type;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_val = a;
- return t;
- }
-
-nodeptr c_str_leaf(type, loc_model, a)
-int type;
-nodeptr loc_model;
-char *a;
- {
- register nodeptr t;
-
- t = NewNode(1);
- t->n_type = type;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_str = a;
- return t;
- }
-
-/*
- * i_str_leaf - create a leaf node containing a string and length.
- */
-nodeptr i_str_leaf(type, loc_model, a, b)
-int type;
-nodeptr loc_model;
-char *a;
-int b;
- {
- register nodeptr t;
-
- t = NewNode(2);
- t->n_type = type;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_str = a;
- t->n_field[1].n_val = b;
- return t;
- }
-
-/*
- * key_leaf - create a leaf node for a keyword.
- */
-nodeptr key_leaf(loc_model, keyname)
-nodeptr loc_model;
-char *keyname;
- {
- register nodeptr t;
- struct implement *ip;
- struct il_code *il;
- char *s;
- int typcd;
-
- /*
- * Find the data base entry for the keyword, if it exists.
- */
- ip = db_ilkup(keyname, khash);
-
- if (ip == NULL)
- tfatal("invalid keyword", keyname);
- else if (ip->in_line == NULL)
- tfatal("keyword not installed", keyname);
- else {
- il = ip->in_line;
- s = il->u[1].s;
- if (il->il_type == IL_Const) {
- /*
- * This is a constant keyword, treat it as a literal.
- */
- t = NewNode(1);
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- typcd = il->u[0].n;
- if (typcd == cset_typ) {
- t->n_type = N_Cset;
- CSym0(t) = putlit(&s[1], F_CsetLit, strlen(s) - 2);
- }
- else if (typcd == int_typ) {
- t->n_type = N_Int;
- CSym0(t) = putlit(s, F_IntLit, 0);
- }
- else if (typcd == real_typ) {
- t->n_type = N_Real;
- CSym0(t) = putlit(s, F_RealLit, 0);
- }
- else if (typcd == str_typ) {
- t->n_type = N_Str;
- CSym0(t) = putlit(&s[1], F_StrLit, strlen(s) - 2);
- }
- return t;
- }
- }
-
- t = NewNode(2);
- t->n_type = N_InvOp;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_val = 0; /* number of arguments */
- t->n_field[1].ip = ip;
- return t;
- }
-
-/*
- * list_nd - create a list creation node.
- */
-nodeptr list_nd(loc_model, args)
-nodeptr loc_model;
-nodeptr args;
- {
- register nodeptr t;
- struct implement *impl;
- int nargs;
-
- /*
- * Determine the number of arguments.
- */
- if (args->n_type == N_Empty)
- nargs = 0;
- else {
- nargs = 1;
- for (t = args; t->n_type == N_Elist; t = t->n_field[0].n_ptr)
- ++nargs;
- if (nargs > max_prm)
- max_prm = nargs;
- }
-
- impl = spec_op[ListOp];
- if (impl == NULL)
- nfatal(loc_model, "list creation not implemented", NULL);
- else if (impl->in_line == NULL)
- nfatal(loc_model, "list creation not installed", NULL);
-
- t = NewNode(nargs + 2);
- t->n_type = N_InvOp;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_val = nargs;
- t->n_field[1].ip = impl;
- if (nargs > 0)
- put_elms(t, args, nargs + 1);
- return t;
- }
-
-/*
- * invk_nd - create a node for invocation.
- */
-nodeptr invk_nd(loc_model, proc, args)
-nodeptr loc_model;
-nodeptr proc;
-nodeptr args;
- {
- register nodeptr t;
- int nargs;
-
- /*
- * Determine the number of arguments.
- */
- if (args->n_type == N_Empty)
- nargs = 0;
- else {
- nargs = 1;
- for (t = args; t->n_type == N_Elist; t = t->n_field[0].n_ptr)
- ++nargs;
- if (nargs > max_prm)
- max_prm = nargs;
- }
-
- t = NewNode(nargs + 2);
- t->n_type = N_Invok;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_val = nargs;
- t->n_field[1].n_ptr = proc;
- if (nargs > 0)
- put_elms(t, args, nargs + 1);
- return t;
- }
-
-/*
- * put_elms - convert a linked list of arguments into an array of arguments
- * in a node.
- */
-static void put_elms(t, args, slot)
-nodeptr t;
-nodeptr args;
-int slot;
- {
- if (args->n_type == N_Elist) {
- /*
- * The linked list is in reverse argument order.
- */
- t->n_field[slot].n_ptr = chk_empty(args->n_field[1].n_ptr);
- put_elms(t, args->n_field[0].n_ptr, slot - 1);
- free(args);
- }
- else
- t->n_field[slot].n_ptr = chk_empty(args);
- }
-
-/*
- * chk_empty - if an argument is empty, replace it with &null.
- */
-static nodeptr chk_empty(n)
-nodeptr n;
- {
- if (n->n_type == N_Empty)
- n = key_leaf(n, spec_str("null"));
- return n;
- }
-
-/*
- * case_nd - create a node for a case statement.
- */
-nodeptr case_nd(loc_model, expr, cases)
-nodeptr loc_model;
-nodeptr expr;
-nodeptr cases;
- {
- register nodeptr t;
- nodeptr reverse;
- nodeptr nxt_cases;
- nodeptr ccls;
-
- t = NewNode(3);
- t->n_type = N_Case;
- t->n_file = loc_model->n_file;
- t->n_line = loc_model->n_line;
- t->n_col = loc_model->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_ptr = expr;
- t->n_field[2].n_ptr = NULL;
-
- /*
- * The list of cases is in reverse order. Walk the list reversing it,
- * and extract the default clause if one exists.
- */
- reverse = NULL;
- while (cases->n_type != N_Ccls) {
- nxt_cases = cases->n_field[0].n_ptr;
- ccls = cases->n_field[1].n_ptr;
- if (ccls->n_field[0].n_ptr->n_type == N_Res) {
- /*
- * default clause.
- */
- if (t->n_field[2].n_ptr == NULL)
- t->n_field[2].n_ptr = ccls->n_field[1].n_ptr;
- else
- nfatal(ccls, "duplicate default clause", NULL);
- }
- else {
- if (reverse == NULL) {
- reverse = cases;
- reverse->n_field[0].n_ptr = ccls;
- }
- else {
- reverse->n_field[1].n_ptr = ccls;
- cases->n_field[0].n_ptr = reverse;
- reverse = cases;
- }
- }
- cases = nxt_cases;
- }
-
- /*
- * Last element in list.
- */
- if (cases->n_field[0].n_ptr->n_type == N_Res) {
- /*
- * default clause.
- */
- if (t->n_field[2].n_ptr == NULL)
- t->n_field[2].n_ptr = cases->n_field[1].n_ptr;
- else
- nfatal(ccls, "duplicate default clause", NULL);
- if (reverse != NULL)
- reverse = reverse->n_field[0].n_ptr;
- }
- else {
- if (reverse == NULL)
- reverse = cases;
- else
- reverse->n_field[1].n_ptr = cases;
- }
- t->n_field[1].n_ptr = reverse;
- return t;
- }
-
-/*
- * multiunary - construct nodes to implement a sequence of unary operators
- * that have been lexically analyzed as one operator.
- */
-nodeptr multiunary(op, loc_model, oprnd)
-nodeptr loc_model;
-char *op;
-nodeptr oprnd;
- {
- int n;
- nodeptr nd;
-
- if (*op == '\0')
- return oprnd;
- for (n = 0; optab[n].tok.t_word != NULL; ++n)
- if ((optab[n].expected & Unary) & (*(optab[n].tok.t_word) == *op)) {
- nd = OpNode(n);
- nd->n_file = loc_model->n_file;
- nd->n_line = loc_model->n_line;
- nd->n_col = loc_model->n_col;
- return unary_nd(nd,multiunary(++op,loc_model,oprnd));
- }
- fprintf(stderr, "compiler error: inconsistent parsing of unary operators");
- exit(EXIT_FAILURE);
- }
-
-/*
- * binary_nd - construct a node for a binary operator.
- */
-nodeptr binary_nd(op, arg1, arg2)
-nodeptr op;
-nodeptr arg1;
-nodeptr arg2;
- {
- register nodeptr t;
- struct implement *impl;
-
- /*
- * Find the data base entry for the operator.
- */
- impl = optab[Val0(op)].binary;
- if (impl == NULL)
- nfatal(op, "binary operator not implemented", optab[Val0(op)].tok.t_word);
- else if (impl->in_line == NULL)
- nfatal(op, "binary operator not installed", optab[Val0(op)].tok.t_word);
-
- t = NewNode(4);
- t->n_type = N_InvOp;
- t->n_file = op->n_file;
- t->n_line = op->n_line;
- t->n_col = op->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_val = 2; /* number of arguments */
- t->n_field[1].ip = impl;
- t->n_field[2].n_ptr = arg1;
- t->n_field[3].n_ptr = arg2;
- return t;
- }
-
-/*
- * unary_nd - construct a node for a unary operator.
- */
-nodeptr unary_nd(op, arg)
-nodeptr op;
-nodeptr arg;
- {
- register nodeptr t;
- struct implement *impl;
-
- /*
- * Find the data base entry for the operator.
- */
- impl = optab[Val0(op)].unary;
- if (impl == NULL)
- nfatal(op, "unary operator not implemented", optab[Val0(op)].tok.t_word);
- else if (impl->in_line == NULL)
- nfatal(op, "unary operator not installed", optab[Val0(op)].tok.t_word);
-
- t = NewNode(3);
- t->n_type = N_InvOp;
- t->n_file = op->n_file;
- t->n_line = op->n_line;
- t->n_col = op->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_val = 1; /* number of arguments */
- t->n_field[1].ip = impl;
- t->n_field[2].n_ptr = arg;
- return t;
- }
-
-/*
- * buildarray - convert "multi-dimensional" subscripting into a sequence
- * of subsripting operations.
- */
-nodeptr buildarray(a,lb,e)
-nodeptr a, lb, e;
- {
- register nodeptr t, t2;
- if (e->n_type == N_Elist) {
- t2 = int_leaf(lb->n_type, lb, lb->n_field[0].n_val);
- t = subsc_nd(t2, buildarray(a,lb,e->n_field[0].n_ptr),
- e->n_field[1].n_ptr);
- free(e);
- }
- else
- t = subsc_nd(lb, a, e);
- return t;
- }
-
-/*
- * subsc_nd - construct a node for subscripting.
- */
-static nodeptr subsc_nd(op, arg1, arg2)
-nodeptr op;
-nodeptr arg1;
-nodeptr arg2;
- {
- register nodeptr t;
- struct implement *impl;
-
- /*
- * Find the data base entry for subscripting.
- */
- impl = spec_op[SubscOp];
- if (impl == NULL)
- nfatal(op, "subscripting not implemented", NULL);
- else if (impl->in_line == NULL)
- nfatal(op, "subscripting not installed", NULL);
-
- t = NewNode(4);
- t->n_type = N_InvOp;
- t->n_file = op->n_file;
- t->n_line = op->n_line;
- t->n_col = op->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_val = 2; /* number of arguments */
- t->n_field[1].ip = impl;
- t->n_field[2].n_ptr = arg1;
- t->n_field[3].n_ptr = arg2;
- return t;
- }
-
-/*
- * to_nd - construct a node for binary to.
- */
-nodeptr to_nd(op, arg1, arg2)
-nodeptr op;
-nodeptr arg1;
-nodeptr arg2;
- {
- register nodeptr t;
- struct implement *impl;
-
- /*
- * Find the data base entry for to.
- */
- impl = spec_op[ToOp];
- if (impl == NULL)
- nfatal(op, "'i to j' not implemented", NULL);
- else if (impl->in_line == NULL)
- nfatal(op, "'i to j' not installed", NULL);
-
- t = NewNode(4);
- t->n_type = N_InvOp;
- t->n_file = op->n_file;
- t->n_line = op->n_line;
- t->n_col = op->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_val = 2; /* number of arguments */
- t->n_field[1].ip = impl;
- t->n_field[2].n_ptr = arg1;
- t->n_field[3].n_ptr = arg2;
- return t;
- }
-
-/*
- * toby_nd - construct a node for binary to-by.
- */
-nodeptr toby_nd(op, arg1, arg2, arg3)
-nodeptr op;
-nodeptr arg1;
-nodeptr arg2;
-nodeptr arg3;
- {
- register nodeptr t;
- struct implement *impl;
-
- /*
- * Find the data base entry for to-by.
- */
- impl = spec_op[ToByOp];
- if (impl == NULL)
- nfatal(op, "'i to j by k' not implemented", NULL);
- else if (impl->in_line == NULL)
- nfatal(op, "'i to j by k' not installed", NULL);
-
- t = NewNode(5);
- t->n_type = N_InvOp;
- t->n_file = op->n_file;
- t->n_line = op->n_line;
- t->n_col = op->n_col;
- t->freetmp = NULL;
- t->n_field[0].n_val = 3; /* number of arguments */
- t->n_field[1].ip = impl;
- t->n_field[2].n_ptr = arg1;
- t->n_field[3].n_ptr = arg2;
- t->n_field[4].n_ptr = arg3;
- return t;
- }
-
-/*
- * aug_nd - create a node for an augmented assignment.
- */
-nodeptr aug_nd(op, arg1, arg2)
-nodeptr op;
-nodeptr arg1;
-nodeptr arg2;
- {
- register nodeptr t;
- struct implement *impl;
-
- t = NewNode(5);
- t->n_type = N_Augop;
- t->n_file = op->n_file;
- t->n_line = op->n_line;
- t->n_col = op->n_col;
- t->freetmp = NULL;
-
- /*
- * Find the data base entry for assignment.
- */
- impl = optab[asgn_loc].binary;
- if (impl == NULL)
- nfatal(op, "assignment not implemented", NULL);
- t->n_field[0].ip = impl;
-
- /*
- * The operator table entry for the augmented assignment is
- * immediately after the entry for the operation.
- */
- impl = optab[Val0(op) - 1].binary;
- if (impl == NULL)
- nfatal(op, "binary operator not implemented",
- optab[Val0(op) - 1].tok.t_word);
- t->n_field[1].ip = impl;
-
- t->n_field[2].n_ptr = arg1;
- t->n_field[3].n_ptr = arg2;
- /* t->n_field[4].typ - type of intermediate result */
- return t;
- }
-
-/*
- * sect_nd - create a node for sectioning.
- */
-nodeptr sect_nd(op, arg1, arg2, arg3)
-nodeptr op;
-nodeptr arg1;
-nodeptr arg2;
-nodeptr arg3;
- {
- register nodeptr t;
- int tok;
- struct implement *impl;
- struct implement *impl1;
-
- t = NewNode(5);
- t->n_file = op->n_file;
- t->n_line = op->n_line;
- t->n_col = op->n_col;
- t->freetmp = NULL;
-
- /*
- * Find the data base entry for sectioning.
- */
- impl = spec_op[SectOp];
- if (impl == NULL)
- nfatal(op, "sectioning not implemented", NULL);
-
- tok = optab[Val0(op)].tok.t_type;
- if (tok == COLON) {
- /*
- * Simple sectioning, treat as a ternary operator.
- */
- t->n_type = N_InvOp;
- t->n_field[0].n_val = 3; /* number of arguments */
- t->n_field[1].ip = impl;
- }
- else {
- /*
- * Find the data base entry for addition or subtraction.
- */
- if (tok == PCOLON) {
- impl1 = optab[plus_loc].binary;
- if (impl1 == NULL)
- nfatal(op, "addition not implemented", NULL);
- }
- else { /* MCOLON */
- impl1 = optab[minus_loc].binary;
- if (impl1 == NULL)
- nfatal(op, "subtraction not implemented", NULL);
- }
- t->n_type = N_Sect;
- t->n_field[0].ip = impl;
- t->n_field[1].ip = impl1;
- }
- t->n_field[2].n_ptr = arg1;
- t->n_field[3].n_ptr = arg2;
- t->n_field[4].n_ptr = arg3;
- return t;
- }
-
-/*
- * invk_main - produce an procedure invocation node with one argument for
- * use in the initial invocation to main() during type inference.
- */
-nodeptr invk_main(main_proc)
-struct pentry *main_proc;
- {
- register nodeptr t;
-
- t = NewNode(3);
- t->n_type = N_InvProc;
- t->n_file = NULL;
- t->n_line = 0;
- t->n_col = 0;
- t->freetmp = NULL;
- t->n_field[0].n_val = 1; /* 1 argument */
- t->n_field[1].proc = main_proc;
- t->n_field[2].n_ptr = tree1(N_Empty);
-
- if (max_prm < 1)
- max_prm = 1;
- return t;
- }
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-19 16:08:27 +0000