/* "p2c", a Pascal to C translator. Copyright (C) 1989 David Gillespie. Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation (any version). This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; see the file COPYING. If not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ #define PROTO_FUNCS5_C #include "trans.h" extern Strlist *enumnames; extern int enumnamecount; Static Expr *func_sqr() { return makeexpr_sqr(p_parexpr(tp_integer), 0); } Static Expr *func_sqrt(ex) Expr *ex; { return makeexpr_bicall_1("sqrt", tp_longreal, grabarg(ex, 0)); } Static Expr *func_swap(ex) Expr *ex; { char *cp; ex = grabarg(ex, 0); cp = swapname; if (!*cp) { note("SWAP function was used [202]"); cp = "SWAP"; } return makeexpr_bicall_1(swapname, tp_int, ex); } Static Expr *func_tan(ex) Expr *ex; { return makeexpr_bicall_1("tan", tp_longreal, grabarg(ex, 0)); } Static Expr *func_tanh(ex) Expr *ex; { return makeexpr_bicall_1("tanh", tp_longreal, grabarg(ex, 0)); } Static Expr *func_trunc(ex) Expr *ex; { return makeexpr_actcast(grabarg(ex, 0), tp_integer); } Static Expr *func_utrunc(ex) Expr *ex; { return makeexpr_actcast(grabarg(ex, 0), tp_unsigned); } Static Expr *func_uand() { Expr *ex; if (!skipopenparen()) return NULL; ex = p_expr(tp_unsigned); if (skipcomma()) { ex = makeexpr_bin(EK_BAND, ex->val.type, ex, p_expr(tp_unsigned)); skipcloseparen(); } return ex; } Static Expr *func_udec() { return handle_vax_hex(NULL, "u", 0); } Static Expr *func_unot() { Expr *ex; if (!skipopenparen()) return NULL; ex = p_expr(tp_unsigned); ex = makeexpr_un(EK_BNOT, ex->val.type, ex); skipcloseparen(); return ex; } Static Expr *func_uor() { Expr *ex; if (!skipopenparen()) return NULL; ex = p_expr(tp_unsigned); if (skipcomma()) { ex = makeexpr_bin(EK_BOR, ex->val.type, ex, p_expr(tp_unsigned)); skipcloseparen(); } return ex; } Static Expr *func_upcase(ex) Expr *ex; { return makeexpr_bicall_1("toupper", tp_char, grabarg(ex, 0)); } Static Expr *func_upper() { Expr *ex; Value val; if (!skipopenparen()) return NULL; ex = p_expr(tp_integer); if (curtok == TOK_COMMA) { gettok(); val = p_constant(tp_integer); if (!val.type || val.i != 1) note("UPPER(v,n) not supported for n>1 [190]"); } skipcloseparen(); return copyexpr(ex->val.type->indextype->smax); } Static Expr *func_uxor() { Expr *ex; if (!skipopenparen()) return NULL; ex = p_expr(tp_unsigned); if (skipcomma()) { ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, p_expr(tp_unsigned)); skipcloseparen(); } return ex; } Static Expr *func_val_modula() { Expr *ex; Type *tp; if (!skipopenparen()) return NULL; tp = p_type(NULL); if (!skipcomma()) return NULL; ex = p_expr(tp); skipcloseparen(); return pascaltypecast(tp, ex); } Static Stmt *proc_val_turbo() { Expr *ex, *vex, *code, *fmt; if (!skipopenparen()) return NULL; ex = gentle_cast(p_expr(tp_str255), tp_str255); if (!skipcomma()) return NULL; vex = p_expr(NULL); if (curtok == TOK_COMMA) { gettok(); code = gentle_cast(p_expr(tp_integer), tp_integer); } else code = NULL; skipcloseparen(); if (vex->val.type->kind == TK_REAL) fmt = makeexpr_string("%lg"); else if (exprlongness(vex) > 0) fmt = makeexpr_string("%ld"); else fmt = makeexpr_string("%d"); ex = makeexpr_bicall_3("sscanf", tp_int, ex, fmt, makeexpr_addr(vex)); if (code) { ex = makeexpr_rel(EK_EQ, ex, makeexpr_long(0)); return makestmt_assign(code, makeexpr_ord(ex)); } else return makestmt_call(ex); } Static Expr *writestrelement(ex, wid, vex, code, needboth) Expr *ex, *wid, *vex; int code, needboth; { if (formatstrings && needboth) { return makeexpr_bicall_5("sprintf", tp_str255, vex, makeexpr_string(format_d("%%*.*%c", code)), copyexpr(wid), wid, ex); } else { return makeexpr_bicall_4("sprintf", tp_str255, vex, makeexpr_string(format_d("%%*%c", code)), wid, ex); } } Static char *makeenumnames(tp) Type *tp; { Strlist *sp; char *name; Meaning *mp; int saveindent; for (sp = enumnames; sp && sp->value != (long)tp; sp = sp->next) ; if (!sp) { if (tp->meaning) name = format_s(name_ENUM, tp->meaning->name); else name = format_s(name_ENUM, format_d("_%d", ++enumnamecount)); sp = strlist_insert(&enumnames, name); sp->value = (long)tp; outsection(2); output(format_s("Static %s *", charname)); output(sp->s); output("[] = {\n"); saveindent = outindent; moreindent(tabsize); moreindent(structinitindent); for (mp = tp->fbase; mp; mp = mp->xnext) { output(makeCstring(mp->sym->name, strlen(mp->sym->name))); if (mp->xnext) output(",\002 "); } outindent = saveindent; output("\n} ;\n"); outsection(2); } return sp->s; } /* This function must return a "tempsprintf" */ Expr *writeelement(ex, wid, prec, base) Expr *ex, *wid, *prec; int base; { Expr *vex, *ex1, *ex2; Meaning *tvar; char *fmtcode; Type *type; ex = makeexpr_charcast(ex); if (ex->val.type->kind == TK_POINTER) { ex = makeexpr_hat(ex, 0); /* convert char *'s to strings */ intwarning("writeelement", "got a char * instead of a string [214]"); } if ((ex->val.type->kind == TK_STRING && !wid) || (ord_type(ex->val.type)->kind == TK_CHAR && (!wid || checkconst(wid, 1)))) { return makeexpr_sprintfify(ex); } tvar = makestmttempvar(tp_str255, name_STRING); vex = makeexpr_var(tvar); if (wid) wid = makeexpr_longcast(wid, 0); if (prec) prec = makeexpr_longcast(prec, 0); #if 0 if (wid && (wid->kind == EK_CONST && wid->val.i < 0 || checkconst(wid, -1))) { freeexpr(wid); /* P-system uses write(x:-1) to mean write(x) */ wid = NULL; } if (prec && (prec->kind == EK_CONST && prec->val.i < 0 || checkconst(prec, -1))) { freeexpr(prec); prec = NULL; } #endif switch (ord_type(ex->val.type)->kind) { case TK_INTEGER: if (!wid) { if (integerwidth < 0) integerwidth = (which_lang == LANG_TURBO) ? 1 : 12; wid = makeexpr_long(integerwidth); } type = findbasetype(ex->val.type, 0); if (base == 16) fmtcode = "x"; else if (base == 8) fmtcode = "o"; else if ((possiblesigns(wid) & (1|4)) == 1) { wid = makeexpr_neg(wid); fmtcode = "x"; } else if (type == tp_unsigned || type == tp_uint || (type == tp_ushort && sizeof_int < 32)) fmtcode = "u"; else fmtcode = "d"; ex = makeexpr_forcelongness(ex); if (checkconst(wid, 0) || checkconst(wid, 1)) { ex = makeexpr_bicall_3("sprintf", tp_str255, vex, makeexpr_string(format_ss("%%%s%s", (exprlongness(ex) > 0) ? "l" : "", fmtcode)), ex); } else { ex = makeexpr_bicall_4("sprintf", tp_str255, vex, makeexpr_string(format_ss("%%*%s%s", (exprlongness(ex) > 0) ? "l" : "", fmtcode)), wid, ex); } break; case TK_CHAR: ex = writestrelement(ex, wid, vex, 'c', (wid->kind != EK_CONST || wid->val.i < 1)); break; case TK_BOOLEAN: if (!wid) { ex = makeexpr_bicall_3("sprintf", tp_str255, vex, makeexpr_string("%s"), makeexpr_cond(ex, makeexpr_string(" TRUE"), makeexpr_string("FALSE"))); } else if (checkconst(wid, 1)) { ex = makeexpr_bicall_3("sprintf", tp_str255, vex, makeexpr_string("%c"), makeexpr_cond(ex, makeexpr_char('T'), makeexpr_char('F'))); } else { ex = writestrelement(makeexpr_cond(ex, makeexpr_string("TRUE"), makeexpr_string("FALSE")), wid, vex, 's', (wid->kind != EK_CONST || wid->val.i < 5)); } break; case TK_ENUM: ex = makeexpr_bicall_3("sprintf", tp_str255, vex, makeexpr_string("%s"), makeexpr_index(makeexpr_name(makeenumnames(ex->val.type), tp_strptr), ex, NULL)); break; case TK_REAL: if (!wid) wid = makeexpr_long(realwidth); if (prec && (possiblesigns(prec) & (1|4)) != 1) { ex = makeexpr_bicall_5("sprintf", tp_str255, vex, makeexpr_string("%*.*f"), wid, prec, ex); } else { if (prec) prec = makeexpr_neg(prec); else prec = makeexpr_minus(copyexpr(wid), makeexpr_long(7)); if (prec->kind == EK_CONST) { if (prec->val.i <= 0) prec = makeexpr_long(1); } else { prec = makeexpr_bicall_2("P_max", tp_integer, prec, makeexpr_long(1)); } if (wid->kind == EK_CONST && wid->val.i > 21) { ex = makeexpr_bicall_5("sprintf", tp_str255, vex, makeexpr_string("%*.*E"), wid, prec, ex); #if 0 } else if (checkconst(wid, 7)) { ex = makeexpr_bicall_3("sprintf", tp_str255, vex, makeexpr_string("%E"), ex); #endif } else { ex = makeexpr_bicall_4("sprintf", tp_str255, vex, makeexpr_string("% .*E"), prec, ex); } } break; case TK_STRING: ex = writestrelement(ex, wid, vex, 's', 1); break; case TK_ARRAY: /* assume packed array of char */ ord_range_expr(ex->val.type->indextype, &ex1, &ex2); ex1 = makeexpr_plus(makeexpr_minus(copyexpr(ex2), copyexpr(ex1)), makeexpr_long(1)); ex1 = makeexpr_longcast(ex1, 0); fmtcode = "%.*s"; if (!wid) { wid = ex1; } else { if (isliteralconst(wid, NULL) == 2 && isliteralconst(ex1, NULL) == 2) { if (wid->val.i > ex1->val.i) { fmtcode = format_ds("%*s%%.*s", wid->val.i - ex1->val.i, ""); wid = ex1; } } else note("Format for packed-array-of-char will work only if width < length [321]"); } ex = makeexpr_bicall_4("sprintf", tp_str255, vex, makeexpr_string(fmtcode), wid, makeexpr_addr(ex)); break; default: note("Element has wrong type for WRITE statement [196]"); ex = makeexpr_bicall_2("sprintf", tp_str255, vex, makeexpr_string("")); break; } return ex; } Static Stmt *handlewrite_text(fex, ex, iswriteln) Expr *fex, *ex; int iswriteln; { Expr *print, *wid, *prec; unsigned char *ucp; int i, done, base; print = NULL; for (;;) { wid = NULL; prec = NULL; base = 10; if (curtok == TOK_COLON && iswriteln >= 0) { gettok(); wid = p_expr(tp_integer); if (curtok == TOK_COLON) { gettok(); prec = p_expr(tp_integer); } } if (curtok == TOK_IDENT && !strcicmp(curtokbuf, "OCT")) { base = 8; gettok(); } else if (curtok == TOK_IDENT && !strcicmp(curtokbuf, "HEX")) { base = 16; gettok(); } ex = writeelement(ex, wid, prec, base); print = makeexpr_concat(print, cleansprintf(ex), 1); if (curtok == TOK_COMMA && iswriteln >= 0) { gettok(); ex = p_expr(NULL); } else break; } if (fex->val.type->kind != TK_STRING) { /* not strwrite */ switch (iswriteln) { case 1: case -1: print = makeexpr_concat(print, makeexpr_string("\n"), 1); break; case 2: case -2: print = makeexpr_concat(print, makeexpr_string("\r"), 1); break; } if (isvar(fex, mp_output)) { ucp = (unsigned char *)print->args[1]->val.s; for (i = 0; i < print->args[1]->val.i; i++) { if (ucp[i] >= 128 && ucp[i] < 144) { note("WRITE statement contains color/attribute characters [203]"); break; } } } if ((i = sprintflength(print, 0)) > 0 && print->nargs == 2 && printfonly != 1) { print = makeexpr_unsprintfify(print); done = 1; if (isvar(fex, mp_output)) { if (i == 1) { print = makeexpr_bicall_1("putchar", tp_int, makeexpr_charcast(print)); } else { if (printfonly == 0) { if (print->val.s[print->val.i-1] == '\n') { print->val.s[--(print->val.i)] = 0; print = makeexpr_bicall_1("puts", tp_int, print); } else { print = makeexpr_bicall_2("fputs", tp_int, print, copyexpr(fex)); } } else { print = makeexpr_sprintfify(print); done = 0; } } } else { if (i == 1) { print = makeexpr_bicall_2("putc", tp_int, makeexpr_charcast(print), copyexpr(fex)); } else if (printfonly == 0) { print = makeexpr_bicall_2("fputs", tp_int, print, copyexpr(fex)); } else { print = makeexpr_sprintfify(print); done = 0; } } } else done = 0; if (!done) { canceltempvar(istempvar(print->args[0])); if (checkstring(print->args[1], "%s") && printfonly != 1) { print = makeexpr_bicall_2("fputs", tp_int, grabarg(print, 2), copyexpr(fex)); } else if (checkstring(print->args[1], "%c") && printfonly != 1 && !nosideeffects(print->args[2], 0)) { print = makeexpr_bicall_2("fputc", tp_int, grabarg(print, 2), copyexpr(fex)); } else if (isvar(fex, mp_output)) { if (checkstring(print->args[1], "%s\n") && printfonly != 1) { print = makeexpr_bicall_1("puts", tp_int, grabarg(print, 2)); } else if (checkstring(print->args[1], "%c") && printfonly != 1) { print = makeexpr_bicall_1("putchar", tp_int, grabarg(print, 2)); } else { strchange(&print->val.s, "printf"); delfreearg(&print, 0); print->val.type = tp_int; } } else { if (checkstring(print->args[1], "%c") && printfonly != 1) { print = makeexpr_bicall_2("putc", tp_int, grabarg(print, 2), copyexpr(fex)); } else { strchange(&print->val.s, "fprintf"); freeexpr(print->args[0]); print->args[0] = copyexpr(fex); print->val.type = tp_int; } } } if (FCheck(checkfilewrite)) { print = makeexpr_bicall_2("~SETIO", tp_void, makeexpr_rel(EK_GE, print, makeexpr_long(0)), makeexpr_name(filewriteerrorname, tp_int)); } } return makestmt_call(print); } Static Stmt *handlewrite_bin(fex, ex) Expr *fex, *ex; { Type *basetype; Stmt *sp; Expr *tvardef = NULL; Meaning *tvar = NULL; sp = NULL; basetype = fex->val.type->basetype->basetype; for (;;) { if (!expr_has_address(ex) || ex->val.type != basetype) { if (!tvar) tvar = makestmttempvar(basetype, name_TEMP); if (!tvardef || !exprsame(tvardef, ex, 1)) { freeexpr(tvardef); tvardef = copyexpr(ex); sp = makestmt_seq(sp, makestmt_assign(makeexpr_var(tvar), ex)); } else freeexpr(ex); ex = makeexpr_var(tvar); } ex = makeexpr_bicall_4("fwrite", tp_integer, makeexpr_addr(ex), makeexpr_sizeof(makeexpr_type(basetype), 0), makeexpr_long(1), copyexpr(fex)); if (FCheck(checkfilewrite)) { ex = makeexpr_bicall_2("~SETIO", tp_void, makeexpr_rel(EK_EQ, ex, makeexpr_long(1)), makeexpr_name(filewriteerrorname, tp_int)); } sp = makestmt_seq(sp, makestmt_call(ex)); if (curtok == TOK_COMMA) { gettok(); ex = p_expr(NULL); } else break; } freeexpr(tvardef); return sp; } Static Stmt *proc_write() { Expr *fex, *ex; Stmt *sp; if (!skipopenparen()) return NULL; ex = p_expr(NULL); if (isfiletype(ex->val.type) && wneedtok(TOK_COMMA)) { fex = ex; ex = p_expr(NULL); } else { fex = makeexpr_var(mp_output); } if (fex->val.type == tp_text) sp = handlewrite_text(fex, ex, 0); else sp = handlewrite_bin(fex, ex); skipcloseparen(); return wrapopencheck(sp, fex); } Static Stmt *handle_modula_write(fmt) char *fmt; { Expr *ex, *wid; if (!skipopenparen()) return NULL; ex = makeexpr_forcelongness(p_expr(NULL)); if (skipcomma()) wid = p_expr(tp_integer); else wid = makeexpr_long(1); if (checkconst(wid, 0) || checkconst(wid, 1)) ex = makeexpr_bicall_2("printf", tp_str255, makeexpr_string(format_ss("%%%s%s", (exprlongness(ex) > 0) ? "l" : "", fmt)), ex); else ex = makeexpr_bicall_3("printf", tp_str255, makeexpr_string(format_ss("%%*%s%s", (exprlongness(ex) > 0) ? "l" : "", fmt)), makeexpr_arglong(wid, 0), ex); skipcloseparen(); return makestmt_call(ex); } Static Stmt *proc_writecard() { return handle_modula_write("u"); } Static Stmt *proc_writeint() { return handle_modula_write("d"); } Static Stmt *proc_writehex() { return handle_modula_write("x"); } Static Stmt *proc_writeoct() { return handle_modula_write("o"); } Static Stmt *proc_writereal() { return handle_modula_write("f"); } Static Stmt *proc_writedir() { Expr *fex, *ex; Stmt *sp; if (!skipopenparen()) return NULL; fex = p_expr(tp_text); if (!skipcomma()) return NULL; ex = p_expr(tp_integer); sp = doseek(fex, ex); if (!skipcomma()) return sp; sp = makestmt_seq(sp, handlewrite_bin(fex, p_expr(NULL))); skipcloseparen(); return wrapopencheck(sp, fex); } Static Stmt *handlewriteln(iswriteln) int iswriteln; { Expr *fex, *ex; Stmt *sp; Meaning *deffile = mp_output; sp = NULL; if (iswriteln == 3) { iswriteln = 1; if (messagestderr) deffile = mp_stderr; } if (curtok != TOK_LPAR) { fex = makeexpr_var(deffile); if (iswriteln) sp = handlewrite_text(fex, makeexpr_string(""), -iswriteln); } else { gettok(); ex = p_expr(NULL); if (isfiletype(ex->val.type)) { fex = ex; if (curtok == TOK_RPAR || !wneedtok(TOK_COMMA)) { if (iswriteln) ex = makeexpr_string(""); else ex = NULL; } else { ex = p_expr(NULL); } } else { fex = makeexpr_var(deffile); } if (ex) sp = handlewrite_text(fex, ex, iswriteln); skipcloseparen(); } if (iswriteln == 0) { sp = makestmt_seq(sp, makestmt_call(makeexpr_bicall_1("fflush", tp_void, copyexpr(fex)))); } return wrapopencheck(sp, fex); } Static Stmt *proc_overprint() { return handlewriteln(2); } Static Stmt *proc_prompt() { return handlewriteln(0); } Static Stmt *proc_writeln() { return handlewriteln(1); } Static Stmt *proc_message() { return handlewriteln(3); } Static Stmt *proc_writev() { Expr *vex, *ex; Stmt *sp; Meaning *mp; if (!skipopenparen()) return NULL; vex = p_expr(tp_str255); if (curtok == TOK_RPAR) { gettok(); return makestmt_assign(vex, makeexpr_string("")); } if (!skipcomma()) return NULL; sp = handlewrite_text(vex, p_expr(NULL), 0); skipcloseparen(); ex = sp->exp1; if (ex->kind == EK_BICALL && !strcmp(ex->val.s, "sprintf") && (mp = istempvar(ex->args[0])) != NULL) { canceltempvar(mp); ex->args[0] = vex; } else sp->exp1 = makeexpr_assign(vex, ex); return sp; } Static Stmt *proc_strwrite(mp_x, spbase) Meaning *mp_x; Stmt *spbase; { Expr *vex, *exi, *exj, *ex; Stmt *sp; Meaning *mp; if (!skipopenparen()) return NULL; vex = p_expr(tp_str255); if (!skipcomma()) return NULL; exi = p_expr(tp_integer); if (!skipcomma()) return NULL; exj = p_expr(tp_integer); if (!skipcomma()) return NULL; sp = handlewrite_text(vex, p_expr(NULL), 0); skipcloseparen(); ex = sp->exp1; FREE(sp); if (checkconst(exi, 1)) { sp = spbase; while (sp && sp->next) sp = sp->next; if (sp && sp->kind == SK_ASSIGN && sp->exp1->kind == EK_ASSIGN && (sp->exp1->args[0]->kind == EK_HAT || sp->exp1->args[0]->kind == EK_INDEX) && exprsame(sp->exp1->args[0]->args[0], vex, 1) && checkconst(sp->exp1->args[1], 0)) { nukestmt(sp); /* remove preceding bogus setstrlen */ } } if (ex->kind == EK_BICALL && !strcmp(ex->val.s, "sprintf") && (mp = istempvar(ex->args[0])) != NULL) { canceltempvar(mp); ex->args[0] = bumpstring(copyexpr(vex), exi, 1); sp = makestmt_call(ex); } else sp = makestmt_assign(bumpstring(copyexpr(vex), exi, 1), ex); if (fullstrwrite != 0) { sp = makestmt_seq(sp, makestmt_assign(exj, makeexpr_plus(makeexpr_bicall_1("strlen", tp_int, vex), makeexpr_long(1)))); if (fullstrwrite == 1) note("FullStrWrite=1 not yet supported [204]"); if (fullstrwrite == 2) note("STRWRITE was used [205]"); } else { freeexpr(vex); } return mixassignments(sp, NULL); } Static Stmt *proc_str_turbo() { Expr *ex, *wid, *prec; if (!skipopenparen()) return NULL; ex = p_expr(NULL); wid = NULL; prec = NULL; if (curtok == TOK_COLON) { gettok(); wid = p_expr(tp_integer); if (curtok == TOK_COLON) { gettok(); prec = p_expr(tp_integer); } } ex = writeelement(ex, wid, prec, 10); if (!skipcomma()) return NULL; wid = p_expr(tp_str255); skipcloseparen(); return makestmt_assign(wid, ex); } Static Expr *func_xor() { Expr *ex, *ex2; Type *type; Meaning *tvar; if (!skipopenparen()) return NULL; ex = p_expr(NULL); if (!skipcomma()) return ex; ex2 = p_expr(ex->val.type); skipcloseparen(); if (ex->val.type->kind != TK_SET && ex->val.type->kind != TK_SMALLSET) { ex = makeexpr_bin(EK_BXOR, ex->val.type, ex, ex2); } else { type = mixsets(&ex, &ex2); tvar = makestmttempvar(type, name_SET); ex = makeexpr_bicall_3(setxorname, type, makeexpr_var(tvar), ex, ex2); } return ex; } void decl_builtins() { makespecialfunc( "ABS", func_abs); makespecialfunc( "ADDR", func_addr); if (!modula2) makespecialfunc( "ADDRESS", func_addr); makespecialfunc( "ADDTOPOINTER", func_addtopointer); makespecialfunc( "ADR", func_addr); makespecialfunc( "ASL", func_lsl); makespecialfunc( "ASR", func_asr); makespecialfunc( "BADDRESS", func_iaddress); makespecialfunc( "BAND", func_uand); makespecialfunc( "BIN", func_bin); makespecialfunc( "BITNEXT", func_bitnext); makespecialfunc( "BITSIZE", func_bitsize); makespecialfunc( "BITSIZEOF", func_bitsize); mp_blockread_ucsd = makespecialfunc( "BLOCKREAD", func_blockread); mp_blockwrite_ucsd = makespecialfunc( "BLOCKWRITE", func_blockwrite); makespecialfunc( "BNOT", func_unot); makespecialfunc( "BOR", func_uor); makespecialfunc( "BSL", func_bsl); makespecialfunc( "BSR", func_bsr); makespecialfunc( "BTST", func_btst); makespecialfunc( "BXOR", func_uxor); makespecialfunc( "BYTEREAD", func_byteread); makespecialfunc( "BYTEWRITE", func_bytewrite); makespecialfunc( "BYTE_OFFSET", func_byte_offset); makespecialfunc( "CHR", func_chr); makespecialfunc( "CONCAT", func_concat); makespecialfunc( "DBLE", func_float); mp_dec_dec = makespecialfunc( "DEC", func_dec); makespecialfunc( "EOF", func_eof); makespecialfunc( "EOLN", func_eoln); makespecialfunc( "FCALL", func_fcall); makespecialfunc( "FILEPOS", func_filepos); makespecialfunc( "FILESIZE", func_filesize); makespecialfunc( "FLOAT", func_float); makespecialfunc( "HEX", func_hex); makespecialfunc( "HI", func_hi); makespecialfunc( "HIWORD", func_hiword); makespecialfunc( "HIWRD", func_hiword); makespecialfunc( "HIGH", func_high); makespecialfunc( "IADDRESS", func_iaddress); makespecialfunc( "INT", func_int); makespecialfunc( "LAND", func_uand); makespecialfunc( "LNOT", func_unot); makespecialfunc( "LO", func_lo); makespecialfunc( "LOOPHOLE", func_loophole); makespecialfunc( "LOR", func_uor); makespecialfunc( "LOWER", func_lower); makespecialfunc( "LOWORD", func_loword); makespecialfunc( "LOWRD", func_loword); makespecialfunc( "LSL", func_lsl); makespecialfunc( "LSR", func_lsr); makespecialfunc( "MAX", func_max); makespecialfunc( "MAXPOS", func_maxpos); makespecialfunc( "MIN", func_min); makespecialfunc( "NEXT", func_sizeof); makespecialfunc( "OCT", func_oct); makespecialfunc( "ORD", func_ord); makespecialfunc( "ORD4", func_ord4); makespecialfunc( "PI", func_pi); makespecialfunc( "POSITION", func_position); makespecialfunc( "PRED", func_pred); makespecialfunc( "QUAD", func_float); makespecialfunc( "RANDOM", func_random); makespecialfunc( "REF", func_addr); makespecialfunc( "SCAN", func_scan); makespecialfunc( "SEEKEOF", func_seekeof); makespecialfunc( "SEEKEOLN", func_seekeoln); makespecialfunc( "SIZE", func_sizeof); makespecialfunc( "SIZEOF", func_sizeof); makespecialfunc( "SNGL", func_sngl); makespecialfunc( "SQR", func_sqr); makespecialfunc( "STATUSV", func_statusv); makespecialfunc( "SUCC", func_succ); makespecialfunc( "TSIZE", func_sizeof); makespecialfunc( "UAND", func_uand); makespecialfunc( "UDEC", func_udec); makespecialfunc( "UINT", func_uint); makespecialfunc( "UNOT", func_unot); makespecialfunc( "UOR", func_uor); makespecialfunc( "UPPER", func_upper); makespecialfunc( "UXOR", func_uxor); mp_val_modula = makespecialfunc( "VAL", func_val_modula); makespecialfunc( "WADDRESS", func_iaddress); makespecialfunc( "XOR", func_xor); makestandardfunc("ARCTAN", func_arctan); makestandardfunc("ARCTANH", func_arctanh); makestandardfunc("BINARY", func_binary); makestandardfunc("CAP", func_upcase); makestandardfunc("COPY", func_copy); makestandardfunc("COS", func_cos); makestandardfunc("COSH", func_cosh); makestandardfunc("EXP", func_exp); makestandardfunc("EXP10", func_pwroften); makestandardfunc("EXPO", func_expo); makestandardfunc("FRAC", func_frac); makestandardfunc("INDEX", func_strpos); makestandardfunc("LASTPOS", NULL); makestandardfunc("LINEPOS", NULL); makestandardfunc("LENGTH", func_strlen); makestandardfunc("LN", func_ln); makestandardfunc("LOG", func_log); makestandardfunc("LOG10", func_log); makestandardfunc("MAXAVAIL", func_maxavail); makestandardfunc("MEMAVAIL", func_memavail); makestandardfunc("OCTAL", func_octal); makestandardfunc("ODD", func_odd); makestandardfunc("PAD", func_pad); makestandardfunc("PARAMCOUNT", func_paramcount); makestandardfunc("PARAMSTR", func_paramstr); makestandardfunc("POS", func_pos); makestandardfunc("PTR", func_ptr); makestandardfunc("PWROFTEN", func_pwroften); makestandardfunc("ROUND", func_round); makestandardfunc("SCANEQ", func_scaneq); makestandardfunc("SCANNE", func_scanne); makestandardfunc("SIN", func_sin); makestandardfunc("SINH", func_sinh); makestandardfunc("SQRT", func_sqrt); mp_str_hp = makestandardfunc("STR", func_str_hp); makestandardfunc("STRLEN", func_strlen); makestandardfunc("STRLTRIM", func_strltrim); makestandardfunc("STRMAX", func_strmax); makestandardfunc("STRPOS", func_strpos); makestandardfunc("STRRPT", func_strrpt); makestandardfunc("STRRTRIM", func_strrtrim); makestandardfunc("SUBSTR", func_str_hp); makestandardfunc("SWAP", func_swap); makestandardfunc("TAN", func_tan); makestandardfunc("TANH", func_tanh); makestandardfunc("TRUNC", func_trunc); makestandardfunc("UPCASE", func_upcase); makestandardfunc("UROUND", func_uround); makestandardfunc("UTRUNC", func_utrunc); makespecialproc( "APPEND", proc_append); makespecialproc( "ARGV", proc_argv); makespecialproc( "ASSERT", proc_assert); makespecialproc( "ASSIGN", proc_assign); makespecialproc( "BCLR", proc_bclr); mp_blockread_turbo = makespecialproc( "BLOCKREAD_TURBO", proc_blockread); mp_blockwrite_turbo = makespecialproc( "BLOCKWRITE_TURBO", proc_blockwrite); makespecialproc( "BREAK", proc_flush); makespecialproc( "BSET", proc_bset); makespecialproc( "CALL", proc_call); makespecialproc( "CLOSE", proc_close); makespecialproc( "CONNECT", proc_assign); makespecialproc( "CYCLE", proc_cycle); mp_dec_turbo = makespecialproc( "DEC_TURBO", proc_dec); makespecialproc( "DISPOSE", proc_dispose); makespecialproc( "ESCAPE", proc_escape); makespecialproc( "EXCL", proc_excl); makespecialproc( "EXIT", proc_exit); makespecialproc( "FILLCHAR", proc_fillchar); makespecialproc( "FLUSH", proc_flush); makespecialproc( "GET", proc_get); makespecialproc( "HALT", proc_escape); makespecialproc( "INC", proc_inc); makespecialproc( "INCL", proc_incl); makespecialproc( "LEAVE", proc_leave); makespecialproc( "LOCATE", proc_seek); makespecialproc( "MESSAGE", proc_message); makespecialproc( "MOVE_FAST", proc_move_fast); makespecialproc( "MOVE_L_TO_R", proc_move_fast); makespecialproc( "MOVE_R_TO_L", proc_move_fast); makespecialproc( "NEW", proc_new); if (which_lang != LANG_VAX) makespecialproc( "OPEN", proc_open); makespecialproc( "OVERPRINT", proc_overprint); makespecialproc( "PACK", NULL); makespecialproc( "PAGE", proc_page); makespecialproc( "PUT", proc_put); makespecialproc( "PROMPT", proc_prompt); makespecialproc( "RANDOMIZE", proc_randomize); makespecialproc( "READ", proc_read); makespecialproc( "READDIR", proc_readdir); makespecialproc( "READLN", proc_readln); makespecialproc( "READV", proc_readv); makespecialproc( "RESET", proc_reset); makespecialproc( "REWRITE", proc_rewrite); makespecialproc( "SEEK", proc_seek); makespecialproc( "SETSTRLEN", proc_setstrlen); makespecialproc( "SETTEXTBUF", proc_settextbuf); mp_str_turbo = makespecialproc( "STR_TURBO", proc_str_turbo); makespecialproc( "STRAPPEND", proc_strappend); makespecialproc( "STRDELETE", proc_strdelete); makespecialproc( "STRINSERT", proc_strinsert); makespecialproc( "STRMOVE", proc_strmove); makespecialproc( "STRREAD", proc_strread); makespecialproc( "STRWRITE", proc_strwrite); makespecialproc( "UNPACK", NULL); makespecialproc( "WRITE", proc_write); makespecialproc( "WRITEDIR", proc_writedir); makespecialproc( "WRITELN", proc_writeln); makespecialproc( "WRITEV", proc_writev); mp_val_turbo = makespecialproc( "VAL_TURBO", proc_val_turbo); makestandardproc("DELETE", proc_delete); makestandardproc("FREEMEM", proc_freemem); makestandardproc("GETMEM", proc_getmem); makestandardproc("GOTOXY", proc_gotoxy); makestandardproc("INSERT", proc_insert); makestandardproc("MARK", NULL); makestandardproc("MOVE", proc_move); makestandardproc("MOVELEFT", proc_move); makestandardproc("MOVERIGHT", proc_move); makestandardproc("RELEASE", NULL); makespecialvar( "MEM", var_mem); makespecialvar( "MEMW", var_memw); makespecialvar( "MEML", var_meml); makespecialvar( "PORT", var_port); makespecialvar( "PORTW", var_portw); /* Modula-2 standard I/O procedures (case-sensitive!) */ makespecialproc( "Read", proc_read); makespecialproc( "ReadCard", proc_read); makespecialproc( "ReadInt", proc_read); makespecialproc( "ReadReal", proc_read); makespecialproc( "ReadString", proc_read); makespecialproc( "Write", proc_write); makespecialproc( "WriteCard", proc_writecard); makespecialproc( "WriteHex", proc_writehex); makespecialproc( "WriteInt", proc_writeint); makespecialproc( "WriteOct", proc_writeoct); makespecialproc( "WriteLn", proc_writeln); makespecialproc( "WriteReal", proc_writereal); makespecialproc( "WriteString", proc_write); } /* End. */