rd.c,
do_comm.c,
modula-2.c,
+ pascal.c,
c.c
} ;
% ISTOKEN
%
%C
-1:-acefiprstuvxAEFGLMPQSTVX,;:+=()*
+1:-acefiprstuvxAEFGLMPQSTVXZ,;:+=()*
%T char istoken[] = {
%p
%T};
{ register p_symbol s;
char *str;
p_type tmp = 0;
+ int upb = 0;
}
:
name(&str)
{ 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)
';'
[ '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,
| '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++;
}
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
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;
}
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;
init_languages()
{
+ add_language(".p", pascal_dep);
add_language(".mod", m2_dep);
add_language(".c", c_dep);
}
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();
--- /dev/null
+/* $Header$ */
+
+/* Language dependant support; this one is for Pascal */
+
+#include <stdio.h>
+#include <alloc.h>
+#include <assert.h>
+#include <ctype.h>
+
+#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 */
+}
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;
}
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);
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;
return sym;
}
-p_scope
+static p_scope
def_scope(s)
p_symbol s;
{
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;
case REGVAR:
case LOCVAR:
case VARPAR:
+ case LBOUND:
+ case UBOUND:
fprintf(db_out, "Variable:\t");
break;
case FIELD:
#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 {
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
#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 */
/* 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;
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);
}
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;
/* 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') */
};
public / ack.git / commitdiff