From: ceriel Date: Tue, 11 Dec 1990 13:53:01 +0000 (+0000) Subject: Added Pascal support X-Git-Tag: release-5-5~1351 X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=64f8785d200e18e91f7d6ff8e76e08abbccb06e2;p=ack.git Added Pascal support --- diff --git a/util/grind/Amakefile b/util/grind/Amakefile index acd8850ec..07c95606c 100644 --- a/util/grind/Amakefile +++ b/util/grind/Amakefile @@ -34,6 +34,7 @@ CSRC = { rd.c, do_comm.c, modula-2.c, + pascal.c, c.c } ; diff --git a/util/grind/char.ct b/util/grind/char.ct index 26c7d829d..e7e7406bb 100644 --- a/util/grind/char.ct +++ b/util/grind/char.ct @@ -65,7 +65,7 @@ STSIMP:-+,!<>{}:`?\\ % ISTOKEN % %C -1:-acefiprstuvxAEFGLMPQSTVX,;:+=()* +1:-acefiprstuvxAEFGLMPQSTVXZ,;:+=()* %T char istoken[] = { %p %T}; diff --git a/util/grind/db_symtab.g b/util/grind/db_symtab.g index 9eab3ecf1..1221fada5 100644 --- a/util/grind/db_symtab.g +++ b/util/grind/db_symtab.g @@ -50,6 +50,7 @@ debugger_string { register p_symbol s; char *str; p_type tmp = 0; + int upb = 0; } : name(&str) @@ -150,6 +151,22 @@ debugger_string { s = NewSymbol(str, CurrentScope, LOCVAR, currnam); } type_name(&(s->sy_type), s) + | /* lower or upper bound of array descriptor */ + [ 'A' { upb = LBOUND; } + | 'Z' { upb = UBOUND; } + ] + [ ['p' | ] { s = NewSymbol(str, CurrentScope, LOCVAR, currnam); + if (upb == UBOUND) add_param_type('Z', s); + } + | [ 'V' | 'S' ] { s = NewSymbol(str, CurrentScope, VAR, currnam); } + ] + type_name(&(s->sy_type), s) + { p_symbol s1 = new_symbol(); + *s1 = *s; + s->sy_class = upb; + s->sy_descr = s1; + } + | /* function result in Pascal; ignore ??? */ { s = NewSymbol(str, CurrentScope, LOCVAR, currnam); } 'X' type_name(&(s->sy_type), s) @@ -367,6 +384,7 @@ type(p_type *ptp; int *type_index; p_symbol sy;) ';' [ 'A' integer_const(&ic2) { A_used |= 2; } | integer_const(&ic2) + | 'Z' integer_const(&ic2) { A_used |= 0200; } ] { if (tp != *ptp) free_type(tp); tp = subrange_type(A_used, @@ -516,7 +534,8 @@ param_list(p_type t;) | 'i' { p->par_kind = 'i'; } ] type(&(p->par_type), (int *) 0, (p_symbol) 0) ';' - { t->ty_nbparams += + { p->par_off = t->ty_nbparams; + t->ty_nbparams += param_size(p->par_type, p->par_kind); p++; } diff --git a/util/grind/expr.c b/util/grind/expr.c index 2bf0a7e5d..af560425d 100644 --- a/util/grind/expr.c +++ b/util/grind/expr.c @@ -152,6 +152,23 @@ get_addr(sym, psize) return 0; } +static int +get_v(a, pbuf, size) + t_addr a; + char **pbuf; + long size; +{ + if (a) { + *pbuf = malloc((unsigned) size); + if (! *pbuf) { + error("could not allocate enough memory"); + return 0; + } + if (! get_bytes(size, a, *pbuf)) return 0; + } + return 1; +} + /* static int get_value(p_symbol sym; char **pbuf; long *psize); Get the value of the symbol indicated by sym. Return 0 on failure, 1 on success. On success, 'pbuf' contains the value, and 'psize' contains @@ -205,17 +222,23 @@ get_value(sym, pbuf, psize) case VARPAR: case LOCVAR: a = get_addr(sym, psize); - if (a) { - size = *psize; - *pbuf = malloc((unsigned) size); - if (! *pbuf) { - error("could not allocate enough memory"); - break; - } - if (get_bytes(size, a, *pbuf)) { - retval = 1; - } - } + retval = get_v(a, pbuf, *psize); + size = *psize; + break; + case UBOUND: + a = get_addr(sym->sy_descr, psize); + retval = get_v(a, pbuf, *psize); + if (! retval) break; + size = get_int(*pbuf, *psize, T_INTEGER); + retval = get_v(a+*psize, pbuf, *psize); + if (! retval) break; + size += get_int(*pbuf, *psize, T_INTEGER); + put_int(*pbuf, *psize, size); + size = *psize; + break; + case LBOUND: + a = get_addr(sym->sy_descr, psize); + retval = get_v(a, pbuf, *psize); break; } @@ -1278,7 +1301,7 @@ eval_expr(p, pbuf, psize, ptp) break; case OP_NAME: case OP_SELECT: - sym = identify(p, VAR|REGVAR|LOCVAR|VARPAR|CONST); + sym = identify(p, VAR|REGVAR|LOCVAR|VARPAR|CONST|LBOUND|UBOUND); if (! sym) return 0; if (! get_value(sym, pbuf, psize)) { break; diff --git a/util/grind/langdep.cc b/util/grind/langdep.cc index 0759b12d3..b584e0151 100644 --- a/util/grind/langdep.cc +++ b/util/grind/langdep.cc @@ -29,6 +29,7 @@ add_language(suff, lang) init_languages() { + add_language(".p", pascal_dep); add_language(".mod", m2_dep); add_language(".c", c_dep); } diff --git a/util/grind/langdep.h b/util/grind/langdep.h index 381cd623b..0e26607ad 100644 --- a/util/grind/langdep.h +++ b/util/grind/langdep.h @@ -36,7 +36,7 @@ struct langdep { int (*fix_bin_to_pref)(); }; -extern struct langdep *m2_dep, *c_dep, *currlang; +extern struct langdep *m2_dep, *c_dep, *pascal_dep, *currlang; extern int find_language(); diff --git a/util/grind/pascal.c b/util/grind/pascal.c new file mode 100644 index 000000000..1f08f219b --- /dev/null +++ b/util/grind/pascal.c @@ -0,0 +1,479 @@ +/* $Header$ */ + +/* Language dependant support; this one is for Pascal */ + +#include +#include +#include +#include + +#include "position.h" +#include "class.h" +#include "langdep.h" +#include "Lpars.h" +#include "idf.h" +#include "token.h" +#include "expr.h" +#include "tree.h" +#include "operator.h" + +extern FILE *db_out, *db_in; + +extern double + atof(); + +extern long + atol(); + +static int + print_string(), + print_char(), + get_number(), + getname(), + get_token(), + getstring(), + print_op(), + binop_prio(), + unop_prio(), + fix_bin_to_pref(); + +static long + array_elsize(); + +static struct langdep pascal = { + 1, + + "%ld", + "0%lo", + "0x%lx", + "%lu", + "0x%lx", + "%.14g", + + "[", + "]", + "(", + ")", + "[", + "]", + + print_string, + print_char, + array_elsize, + binop_prio, + unop_prio, + getstring, + getname, + get_number, + get_token, + print_op, + fix_bin_to_pref +}; + +struct langdep *pascal_dep = &pascal; + +static +print_char(c) + int c; +{ + c &= 0377; + fprintf(db_out, (c >= 040 && c < 0177) ? "'%c'" : "chr(%d)", c); +} + +static +print_string(f, s, len) + FILE *f; + char *s; + int len; +{ + register char *str = s; + + putc('\'', f); + while (*str && len > 0) { + putc(*str, f); + if (*str++ == '\'') putc('\'', f); + len--; + } + putc('\'', f); +} + +extern long int_size; + +static long +array_elsize(size) + long size; +{ + if (! (int_size % size)) return size; + if (! (size % int_size)) return size; + return ((size + int_size - 1) / int_size) * int_size; +} + +static int +unop_prio(op) + int op; +{ + switch(op) { + case E_NOT: + return 8; + case E_MIN: + case E_PLUS: + return 6; + } + return 1; +} + +static int +binop_prio(op) + int op; +{ + switch(op) { + case E_SELECT: + return 9; + case E_ARRAY: + return 9; + case E_AND: + case E_MUL: + case E_DIV: + case E_MOD: + return 7; + + case E_PLUS: + case E_MIN: + case E_OR: + return 6; + + case E_IN: + case E_EQUAL: + case E_NOTEQUAL: + case E_LTEQUAL: + case E_GTEQUAL: + case E_LT: + case E_GT: + return 5; + } + return 1; +} + +static int +get_number(ch) + register int ch; +{ + char buf[512+1]; + register char *np = &buf[0]; + int real_mode = 0; + + while (is_dig(ch)) { + if (np < &buf[512]) *np++ = ch; + ch = getc(db_in); + } + + if (ch == '.') { + real_mode = 1; + if (np < &buf[512]) *np++ = '.'; + ch = getc(db_in); + while (is_dig(ch)) { + /* Fractional part + */ + if (np < &buf[512]) *np++ = ch; + ch = getc(db_in); + } + } + + if (ch == 'E' || ch == 'e') { + /* Scale factor + */ + real_mode = 1; + if (np < &buf[512]) *np++ = ch; + ch = getc(db_in); + if (ch == '+' || ch == '-') { + /* Signed scalefactor + */ + if (np < &buf[512]) *np++ = ch; + ch = getc(db_in); + } + if (is_dig(ch)) { + do { + if (np < &buf[512]) *np++ = ch; + ch = getc(db_in); + } while (is_dig(ch)); + } + else { + error("bad scale factor"); + } + } + + *np++ = '\0'; + ungetc(ch, db_in); + + if (np >= &buf[512]) { + if (! real_mode) { + tok.ival = 0; + error("constant too long"); + } + else { + tok.fval = 0.0; + error("real constant too long"); + } + } + else if (! real_mode) { + tok.ival = atol(buf); + return INTEGER; + } + tok.fval = atof(buf); + return REAL; +} + +static int +getname(c) + register int c; +{ + char buf[512+1]; + register char *p = &buf[0]; + register struct idf *id; + + do { + if (isupper(c)) c = tolower(c); + if (p - buf < 512) *p++ = c; + c = getc(db_in); + } while (in_idf(c)); + ungetc(c, db_in); + *p = 0; + /* now recognize and, div, in, mod, not, or */ + switch(buf[0]) { + case 'a': + if (strcmp(buf, "and") == 0) { + tok.ival = E_AND; + return BIN_OP; + } + break; + case 'd': + if (strcmp(buf, "div") == 0) { + tok.ival = E_DIV; + return BIN_OP; + } + break; + case 'i': + if (strcmp(buf, "in") == 0) { + tok.ival = E_IN; + return BIN_OP; + } + break; + case 'm': + if (strcmp(buf, "mod") == 0) { + tok.ival = E_MOD; + return BIN_OP; + } + break; + case 'n': + if (strcmp(buf, "not") == 0) { + tok.ival = E_NOT; + return PREF_OP; + } + break; + case 'o': + if (strcmp(buf, "or") == 0) { + tok.ival = E_OR; + return BIN_OP; + } + break; + } + id = str2idf(buf, 1); + tok.idf = id; + tok.str = id->id_text; + return id->id_reserved ? id->id_reserved : NAME; +} + +static int +get_token(c) + register int c; +{ + switch(c) { + case '[': + tok.ival = E_ARRAY; + /* fall through */ + case '(': + case ')': + case ']': + case '`': + case '{': + case '}': + case ':': + case ',': + case '\\': + return c; + + case '.': + tok.ival = E_SELECT; + return SEL_OP; + case '+': + tok.ival = E_PLUS; + return PREF_OR_BIN_OP; + case '-': + tok.ival = E_MIN; + return PREF_OR_BIN_OP; + case '*': + tok.ival = E_MUL; + return BIN_OP; + case '/': + tok.ival = E_DIV; + return BIN_OP; + case '=': + tok.ival = E_EQUAL; + return BIN_OP; + case '<': + c = getc(db_in); + if (c == '>') { + tok.ival = E_NOTEQUAL; + return BIN_OP; + } + if (c == '=') { + tok.ival = E_LTEQUAL; + return BIN_OP; + } + ungetc(c, db_in); + tok.ival = E_LT; + return BIN_OP; + case '>': + c = getc(db_in); + if (c == '=') { + tok.ival = E_GTEQUAL; + return BIN_OP; + } + ungetc(c, db_in); + tok.ival = E_GT; + return BIN_OP; + case '^': + tok.ival = E_DEREF; + return POST_OP; + default: + error((c >= 040 && c < 0177) ? "%s'%c'" : "%s'\\0%o'", "illegal character ", c); + return LLlex(); + } +} + +static int +getstring(c) + int c; +{ + register int ch; + char buf[512]; + register int len = 0; + + for (;;) { + ch = getc(db_in); + if (ch == c) { + ch = getc(db_in); + if (ch != c) { + ungetc(ch, db_in); + break; + } + } + if (ch == '\n') { + error("newline in string"); + ungetc(ch, db_in); + break; + } + buf[len++] = ch; + } + buf[len++] = 0; + tok.str = Salloc(buf, (unsigned) len); + return STRING; +} + +static +print_op(f, p) + FILE *f; + p_tree p; +{ + switch(p->t_oper) { + case OP_UNOP: + switch(p->t_whichoper) { + case E_MIN: + fputs("-", f); + print_node(f, p->t_args[0], 0); + break; + case E_PLUS: + fputs("+", f); + print_node(f, p->t_args[0], 0); + break; + case E_NOT: + fputs(" not ", f); + print_node(f, p->t_args[0], 0); + break; + case E_DEREF: + print_node(f, p->t_args[0], 0); + fputs("^", f); + break; + } + break; + case OP_BINOP: + if (p->t_whichoper == E_ARRAY) { + print_node(f, p->t_args[0], 0); + fputs("[", f); + print_node(f, p->t_args[1], 0); + fputs("]", f); + break; + } + if (p->t_whichoper == E_SELECT) { + print_node(f, p->t_args[0], 0); + fputs(".", f); + print_node(f, p->t_args[1], 0); + break; + } + fputs("(", f); + print_node(f, p->t_args[0], 0); + switch(p->t_whichoper) { + case E_AND: + fputs(" and ", f); + break; + case E_OR: + fputs(" or ", f); + break; + case E_DIV: + fputs("/", f); + break; + case E_MOD: + fputs(" mod ", f); + break; + case E_IN: + fputs(" in ", f); + break; + case E_PLUS: + fputs("+", f); + break; + case E_MIN: + fputs("-", f); + break; + case E_MUL: + fputs("*", f); + break; + case E_EQUAL: + fputs("=", f); + break; + case E_NOTEQUAL: + fputs("<>", f); + break; + case E_LTEQUAL: + fputs("<=", f); + break; + case E_GTEQUAL: + fputs(">=", f); + break; + case E_LT: + fputs("<", f); + break; + case E_GT: + fputs(">", f); + break; + } + print_node(f, p->t_args[1], 0); + fputs(")", f); + break; + } +} + +static +fix_bin_to_pref() +{ + /* No problems of this kind in Pascal */ +} diff --git a/util/grind/print.c b/util/grind/print.c index a551b0803..a5f12a39d 100644 --- a/util/grind/print.c +++ b/util/grind/print.c @@ -139,13 +139,13 @@ print_params(tp, AB, static_link) error("could not allocate enough memory"); return; } - if (static_link) p += pointer_size; - if (! get_bytes(size, AB, param_bytes)) { - free(param_bytes); + if (! get_bytes(size, AB, p)) { + free(p); return; } while (i--) { + p = param_bytes + par->par_off; if (par->par_kind == 'v' || par->par_kind == 'i') { /* call by reference parameter, or call by value parameter, but address is passed; @@ -173,7 +173,6 @@ print_params(tp, AB, static_link) } else print_val(par->par_type, par->par_type->ty_size, p, 1, 0, (char *)0); if (i) fputs(", ", db_out); - p += param_size(par->par_type, par->par_kind); par++; } free(param_bytes); diff --git a/util/grind/run.c b/util/grind/run.c index 3e631200f..7c6aaac44 100644 --- a/util/grind/run.c +++ b/util/grind/run.c @@ -203,10 +203,14 @@ start_child(p) exit(1); } - /* debugger; don't close fild1[0] and fild2[1]; we want those file - descriptors occupied! + /* close fild1[0] and fild2[1]; but we want those file descriptors occupied, + so we re-occupy them. */ + close(fild1[0]); + close(fild2[1]); + pipe(fild1); /* to occupy file descriptors */ + signal(SIGPIPE, catch_sigpipe); { struct message_hdr m; diff --git a/util/grind/symbol.c b/util/grind/symbol.c index 94439d16b..ee14fabd6 100644 --- a/util/grind/symbol.c +++ b/util/grind/symbol.c @@ -129,7 +129,7 @@ add_file(s) return sym; } -p_scope +static p_scope def_scope(s) p_symbol s; { @@ -169,7 +169,7 @@ consistent(p, sc) switch(p->t_oper) { case OP_NAME: -#define CLASS (FILELINK|FILESYM|PROC|FUNCTION|MODULE|TYPE|VAR|REGVAR|LOCVAR|VARPAR) +#define CLASS (FILELINK|FILESYM|PROC|FUNCTION|MODULE|TYPE|VAR|REGVAR|LOCVAR|VARPAR|LBOUND|UBOUND) sym = Lookfromscope(p->t_idf, CLASS, sc->sc_static_encl); if (sym) { int precise = 1; @@ -322,6 +322,8 @@ pr_sym(s) case REGVAR: case LOCVAR: case VARPAR: + case LBOUND: + case UBOUND: fprintf(db_out, "Variable:\t"); break; case FIELD: diff --git a/util/grind/symbol.hh b/util/grind/symbol.hh index 4fa89ba68..b8a4f809b 100644 --- a/util/grind/symbol.hh +++ b/util/grind/symbol.hh @@ -35,6 +35,8 @@ typedef struct symbol { #define FIELD 0x0400 #define FILESYM 0x0800 /* a filename */ #define FILELINK 0x1000 /* a filename without its suffix */ +#define LBOUND 0x2000 /* lower bound of array descriptor */ +#define UBOUND 0x4000 /* upper bound of array descriptor */ struct idf *sy_idf; /* reference back to its idf structure */ struct scope *sy_scope; /* scope in which this symbol resides */ union { @@ -42,6 +44,7 @@ typedef struct symbol { t_name syv_name; struct file *syv_file; /* for FILESYM */ struct symbol *syv_fllink; /* for FILELINK */ + struct symbol *syv_descr; /* for LBOUND and UBOUND */ struct fields *syv_field; } sy_v; #define sy_const sy_v.syv_const @@ -49,6 +52,7 @@ typedef struct symbol { #define sy_file sy_v.syv_file #define sy_filelink sy_v.syv_fllink #define sy_field sy_v.syv_field +#define sy_descr sy_v.syv_descr } t_symbol, *p_symbol; /* ALLOCDEF "symbol" 50 */ diff --git a/util/grind/type.c b/util/grind/type.c index 6469ab800..9ba6867ac 100644 --- a/util/grind/type.c +++ b/util/grind/type.c @@ -369,7 +369,8 @@ param_size(t, v) /* addresss; only exception is a conformant array, which also takes a descriptor. */ - if (t->ty_class == T_ARRAY && + if (currlang == m2_dep && + t->ty_class == T_ARRAY && t->ty_index->ty_class == T_SUBRANGE && t->ty_index->ty_A) { return pointer_size + 3 * int_size; @@ -390,11 +391,16 @@ add_param_type(v, s) prc_type = sc->sc_definedby->sy_type; assert(prc_type->ty_class == T_PROCEDURE); + if (v == 'Z') { + prc_type->ty_nbparams += 3 * int_size; + return; + } prc_type->ty_nparams++; prc_type->ty_params = (struct param *) Realloc((char *) prc_type->ty_params, (unsigned)prc_type->ty_nparams * sizeof(struct param)); prc_type->ty_params[prc_type->ty_nparams - 1].par_type = s->sy_type; prc_type->ty_params[prc_type->ty_nparams - 1].par_kind = v; + prc_type->ty_params[prc_type->ty_nparams - 1].par_off = s->sy_name.nm_value; prc_type->ty_nbparams += param_size(s->sy_type, v); } @@ -418,6 +424,9 @@ compute_size(tp, AB) tp->ty_lb = low; if (tp->ty_index->ty_A & 2) { high = get_int(AB+tp->ty_index->ty_up, int_size, T_INTEGER); + } else if (tp->ty_index->ty_A & 0200) { + high = get_int(AB+tp->ty_index->ty_up, int_size, T_INTEGER); + high += get_int(AB+tp->ty_index->ty_up+int_size, int_size, T_INTEGER); } else high = tp->ty_index->ty_up; tp->ty_hb = high; return (high - low + 1) * tp->ty_elements->ty_size; diff --git a/util/grind/type.hh b/util/grind/type.hh index 7a361c9ee..9baeb9169 100644 --- a/util/grind/type.hh +++ b/util/grind/type.hh @@ -19,6 +19,7 @@ struct literal { /* structure for parameters */ struct param { struct type *par_type; /* type of parameter */ + long par_off; /* offset of parameter */ char par_kind; /* kind of parameter ('p', 'i', or 'v') */ };