home *** CD-ROM | disk | FTP | other *** search
- Subject: v21i055: Pascal to C translator, Part10/32
- Newsgroups: comp.sources.unix
- Approved: rsalz@uunet.UU.NET
- X-Checksum-Snefru: fe92997f dac1df9a 2ff3c79f dc5efb99
-
- Submitted-by: Dave Gillespie <daveg@csvax.caltech.edu>
- Posting-number: Volume 21, Issue 55
- Archive-name: p2c/part10
-
- #! /bin/sh
- # This is a shell archive. Remove anything before this line, then unpack
- # it by saving it into a file and typing "sh file". To overwrite existing
- # files, type "sh file -c". You can also feed this as standard input via
- # unshar, or by typing "sh <file", e.g.. If this archive is complete, you
- # will see the following message at the end:
- # "End of archive 10 (of 32)."
- # Contents: src/citmods.c
- # Wrapped by rsalz@litchi.bbn.com on Mon Mar 26 14:29:34 1990
- PATH=/bin:/usr/bin:/usr/ucb ; export PATH
- if test -f 'src/citmods.c' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'src/citmods.c'\"
- else
- echo shar: Extracting \"'src/citmods.c'\" \(31407 characters\)
- sed "s/^X//" >'src/citmods.c' <<'END_OF_FILE'
- X/* "p2c", a Pascal to C translator.
- X Copyright (C) 1989 David Gillespie.
- X Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.
- X
- XThis program is free software; you can redistribute it and/or modify
- Xit under the terms of the GNU General Public License as published by
- Xthe Free Software Foundation (any version).
- X
- XThis program is distributed in the hope that it will be useful,
- Xbut WITHOUT ANY WARRANTY; without even the implied warranty of
- XMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- XGNU General Public License for more details.
- X
- XYou should have received a copy of the GNU General Public License
- Xalong with this program; see the file COPYING. If not, write to
- Xthe Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
- X
- X
- X
- X#define PROTO_CITMODS_C
- X#include "trans.h"
- X
- X
- X
- X/* The following functions define special translations for several
- X * HP Pascal modules developed locally at Caltech. For non-Caltech
- X * readers this file will serve mainly as a body of examples.
- X *
- X * The FuncMacro mechanism (introduced after this file was written)
- X * provides a simpler method for cases where the function translates
- X * into some fixed C equivalent.
- X */
- X
- X
- X
- X
- X/* NEWASM functions */
- X
- X
- X/* na_fillbyte: equivalent to memset, though convert_size is used to
- X * generalize the size a bit: na_fillbyte(a, 0, 80) where a is an array
- X * of integers (4 bytes in HP Pascal) will be translated to
- X * memset(a, 0, 20 * sizeof(int)).
- X */
- X
- XStatic Stmt *proc_na_fillbyte(ex)
- XExpr *ex;
- X{
- X ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
- X ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_FILLBYTE");
- X return makestmt_call(makeexpr_bicall_3("memset", tp_void,
- X ex->args[0],
- X makeexpr_arglong(ex->args[1], 0),
- X makeexpr_arglong(ex->args[2], (size_t_long != 0))));
- X}
- X
- X
- X
- X/* This function fills with a 32-bit pattern. If all four bytes of the
- X * pattern are equal, memset is used, otherwise the na_fill call is
- X * left unchanged.
- X */
- X
- XStatic Stmt *proc_na_fill(ex)
- XExpr *ex;
- X{
- X unsigned long ul;
- X Symbol *sym;
- X
- X ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
- X ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_FILL");
- X if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_FILLP")) {
- X sym = findsymbol("NA_FILL");
- X if (sym->mbase)
- X ex->val.i = (long)sym->mbase;
- X }
- X if (isliteralconst(ex->args[1], NULL) != 2)
- X return makestmt_call(ex);
- X ul = ex->args[1]->val.i;
- X if ((((ul >> 16) ^ ul) & 0xffff) || /* all four bytes must be the same */
- X (((ul >> 8) ^ ul) & 0xff))
- X return makestmt_call(ex);
- X ex->args[1]->val.i &= 0xff;
- X return makestmt_call(makeexpr_bicall_3("memset", tp_void,
- X ex->args[0],
- X makeexpr_arglong(ex->args[1], 0),
- X makeexpr_arglong(ex->args[2], (size_t_long != 0))));
- X}
- X
- X
- X
- XStatic Stmt *proc_na_move(ex)
- XExpr *ex;
- X{
- X ex->args[0] = gentle_cast(ex->args[0], tp_anyptr); /* source */
- X ex->args[1] = gentle_cast(ex->args[1], tp_anyptr); /* dest */
- X ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
- X argbasetype(ex->args[1])), ex->args[2], "NA_MOVE");
- X return makestmt_call(makeexpr_bicall_3("memmove", tp_void,
- X ex->args[1],
- X ex->args[0],
- X makeexpr_arglong(ex->args[2], (size_t_long != 0))));
- X}
- X
- X
- X
- X/* This just generalizes the size and leaves the function call alone,
- X * except that na_exchp (a version using pointer args) is transformed
- X * to na_exch (a version using VAR args, equivalent in C).
- X */
- X
- XStatic Stmt *proc_na_exch(ex)
- XExpr *ex;
- X{
- X Symbol *sym;
- X
- X ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
- X ex->args[1] = gentle_cast(ex->args[1], tp_anyptr);
- X ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
- X argbasetype(ex->args[1])), ex->args[2], "NA_EXCH");
- X if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_EXCHP")) {
- X sym = findsymbol("NA_EXCH");
- X if (sym->mbase)
- X ex->val.i = (long)sym->mbase;
- X }
- X return makestmt_call(ex);
- X}
- X
- X
- X
- XStatic Expr *func_na_comp(ex)
- XExpr *ex;
- X{
- X ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
- X ex->args[1] = gentle_cast(ex->args[1], tp_anyptr);
- X ex->args[2] = convert_size(choosetype(argbasetype(ex->args[0]),
- X argbasetype(ex->args[1])), ex->args[2], "NA_COMP");
- X return makeexpr_bicall_3("memcmp", tp_int,
- X ex->args[0],
- X ex->args[1],
- X makeexpr_arglong(ex->args[2], (size_t_long != 0)));
- X}
- X
- X
- X
- XStatic Expr *func_na_scaneq(ex)
- XExpr *ex;
- X{
- X Symbol *sym;
- X
- X ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
- X ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_SCANEQ");
- X if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_SCANEQP")) {
- X sym = findsymbol("NA_SCANEQ");
- X if (sym->mbase)
- X ex->val.i = (long)sym->mbase;
- X }
- X return ex;
- X}
- X
- X
- X
- XStatic Expr *func_na_scanne(ex)
- XExpr *ex;
- X{
- X Symbol *sym;
- X
- X ex->args[0] = gentle_cast(ex->args[0], tp_anyptr);
- X ex->args[2] = convert_size(argbasetype(ex->args[0]), ex->args[2], "NA_SCANNE");
- X if (!strcmp(((Meaning *)ex->val.i)->sym->name, "NA_SCANNEP")) {
- X sym = findsymbol("NA_SCANNE");
- X if (sym->mbase)
- X ex->val.i = (long)sym->mbase;
- X }
- X return ex;
- X}
- X
- X
- X
- XStatic Stmt *proc_na_new(ex)
- XExpr *ex;
- X{
- X Expr *vex, *ex2, *sz = NULL;
- X Stmt *sp;
- X
- X vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
- X ex2 = ex->args[1];
- X if (vex->val.type->kind == TK_POINTER)
- X ex2 = convert_size(vex->val.type->basetype, ex2, "NA_NEW");
- X if (alloczeronil)
- X sz = copyexpr(ex2);
- X ex2 = makeexpr_bicall_1(mallocname, tp_anyptr, ex2);
- X sp = makestmt_assign(copyexpr(vex), ex2);
- X if (malloccheck) {
- X sp = makestmt_seq(sp, makestmt_if(makeexpr_rel(EK_EQ, copyexpr(vex), makeexpr_nil()),
- X makestmt_call(makeexpr_bicall_1(name_ESCAPE, tp_int,
- X makeexpr_long(-2))),
- X NULL));
- X }
- X if (sz && !isconstantexpr(sz)) {
- X if (alloczeronil == 2)
- X note("Called NA_NEW with variable argument [500]");
- X sp = makestmt_if(makeexpr_rel(EK_NE, sz, makeexpr_long(0)),
- X sp,
- X makestmt_assign(vex, makeexpr_nil()));
- X } else
- X freeexpr(vex);
- X return sp;
- X}
- X
- X
- X
- XStatic Stmt *proc_na_dispose(ex)
- XExpr *ex;
- X{
- X Stmt *sp;
- X Expr *vex;
- X
- X vex = makeexpr_hat(eatcasts(ex->args[0]), 0);
- X sp = makestmt_call(makeexpr_bicall_1(freename, tp_void, copyexpr(vex)));
- X if (alloczeronil) {
- X sp = makestmt_if(makeexpr_rel(EK_NE, vex, makeexpr_nil()),
- X sp, NULL);
- X } else
- X freeexpr(vex);
- X return sp;
- X}
- X
- X
- X
- X/* These functions provide functionality similar to alloca; we just warn
- X * about them here since alloca would not have been portable enough for
- X * our purposes anyway.
- X */
- X
- XStatic Stmt *proc_na_alloc(ex)
- XExpr *ex;
- X{
- X Expr *ex2;
- X
- X note("Call to NA_ALLOC [501]");
- X ex->args[0] = eatcasts(ex->args[0]);
- X ex2 = ex->args[0];
- X if (ex2->val.type->kind == TK_POINTER &&
- X ex2->val.type->basetype->kind == TK_POINTER)
- X ex->args[1] = convert_size(ex2->val.type->basetype->basetype,
- X ex->args[1], "NA_ALLOC");
- X return makestmt_call(ex);
- X}
- X
- X
- X
- XStatic Stmt *proc_na_outeralloc(ex)
- XExpr *ex;
- X{
- X note("Call to NA_OUTERALLOC [502]");
- X return makestmt_call(ex);
- X}
- X
- X
- X
- XStatic Stmt *proc_na_free(ex)
- XExpr *ex;
- X{
- X note("Call to NA_FREE [503]");
- X return makestmt_call(ex);
- X}
- X
- X
- X
- X
- XStatic Expr *func_na_memavail(ex)
- XExpr *ex;
- X{
- X freeexpr(ex);
- X return makeexpr_bicall_0("memavail", tp_integer);
- X}
- X
- X
- X
- X
- X/* A simple collection of bitwise operations. */
- X
- XStatic Expr *func_na_and(ex)
- XExpr *ex;
- X{
- X Expr *ex0, *ex1;
- X
- X ex0 = makeexpr_unlongcast(ex->args[0]);
- X ex1 = makeexpr_unlongcast(ex->args[1]);
- X return makeexpr_bin(EK_BAND, tp_integer, ex0, ex1);
- X}
- X
- X
- X
- XStatic Expr *func_na_bic(ex)
- XExpr *ex;
- X{
- X Expr *ex0, *ex1;
- X
- X ex0 = makeexpr_unlongcast(ex->args[0]);
- X ex1 = makeexpr_unlongcast(ex->args[1]);
- X return makeexpr_bin(EK_BAND, tp_integer,
- X ex0,
- X makeexpr_un(EK_BNOT, ex1->val.type, ex1));
- X}
- X
- X
- X
- XStatic Expr *func_na_or(ex)
- XExpr *ex;
- X{
- X Expr *ex0, *ex1;
- X
- X ex0 = makeexpr_unlongcast(ex->args[0]);
- X ex1 = makeexpr_unlongcast(ex->args[1]);
- X return makeexpr_bin(EK_BOR, tp_integer, ex0, ex1);
- X}
- X
- X
- X
- XStatic Expr *func_na_xor(ex)
- XExpr *ex;
- X{
- X Expr *ex0, *ex1;
- X
- X ex0 = makeexpr_unlongcast(ex->args[0]);
- X ex1 = makeexpr_unlongcast(ex->args[1]);
- X return makeexpr_bin(EK_BXOR, tp_integer, ex0, ex1);
- X}
- X
- X
- X
- XStatic Expr *func_na_not(ex)
- XExpr *ex;
- X{
- X ex = makeexpr_unlongcast(grabarg(ex, 0));
- X return makeexpr_un(EK_BNOT, ex->val.type, ex);
- X}
- X
- X
- X
- XStatic Expr *func_na_mask(ex)
- XExpr *ex;
- X{
- X Expr *ex0, *ex1;
- X
- X ex0 = makeexpr_unlongcast(ex->args[0]);
- X ex1 = makeexpr_unlongcast(ex->args[1]);
- X ex = makeexpr_bin(EK_BAND, tp_integer, ex0, ex1);
- X return makeexpr_rel(EK_NE, ex, makeexpr_long(0));
- X}
- X
- X
- X
- XStatic int check0_31(ex)
- XExpr *ex;
- X{
- X if (isliteralconst(ex, NULL) == 2)
- X return (ex->val.i >= 0 && ex->val.i <= 31);
- X else
- X return (assumebits != 0);
- X}
- X
- X
- X
- X/* This function is defined to test a bit of an integer, returning false
- X * if the bit number is out of range. It is only safe to use C bitwise
- X * ops if we can prove the bit number is always in range, or if the
- X * user has asked us to assume that it is. Lacking flow analysis,
- X * we settle for checking constants only.
- X */
- X
- XStatic Expr *func_na_test(ex)
- XExpr *ex;
- X{
- X Expr *ex1;
- X int longness;
- X
- X if (!check0_31(ex->args[0]))
- X return ex;
- X ex1 = makeexpr_unlongcast(ex->args[1]);
- X longness = (exprlongness(ex1) != 0);
- X return makeexpr_rel(EK_NE,
- X makeexpr_bin(EK_BAND, tp_integer,
- X ex1,
- X makeexpr_bin(EK_LSH, tp_integer,
- X makeexpr_longcast(makeexpr_long(1), longness),
- X makeexpr_unlongcast(ex->args[0]))),
- X makeexpr_long(0));
- X}
- X
- X
- X
- XStatic Stmt *proc_na_set(ex)
- XExpr *ex;
- X{
- X Stmt *sp;
- X Expr *vex;
- X Meaning *tvar;
- X
- X if (!check0_31(ex->args[0]))
- X return makestmt_call(ex);
- X if (!nosideeffects(ex->args[1], 1)) {
- X tvar = makestmttempvar(ex->args[1]->val.type, name_TEMP);
- X sp = makestmt_assign(makeexpr_var(tvar), ex->args[1]);
- X vex = makeexpr_hat(makeexpr_var(tvar), 0);
- X } else {
- X sp = NULL;
- X vex = makeexpr_hat(ex->args[1], 0);
- X }
- X sp = makestmt_seq(sp,
- X makestmt_assign(vex,
- X makeexpr_bin(EK_BOR, tp_integer,
- X copyexpr(vex),
- X makeexpr_bin(EK_LSH, tp_integer,
- X makeexpr_longcast(makeexpr_long(1), 1),
- X makeexpr_unlongcast(ex->args[0])))));
- X return sp;
- X}
- X
- X
- X
- XStatic Stmt *proc_na_clear(ex)
- XExpr *ex;
- X{
- X Stmt *sp;
- X Expr *vex;
- X Meaning *tvar;
- X
- X if (!check0_31(ex->args[0]))
- X return makestmt_call(ex);
- X if (!nosideeffects(ex->args[1], 1)) {
- X tvar = makestmttempvar(ex->args[1]->val.type, name_TEMP);
- X sp = makestmt_assign(makeexpr_var(tvar), ex->args[1]);
- X vex = makeexpr_hat(makeexpr_var(tvar), 0);
- X } else {
- X sp = NULL;
- X vex = makeexpr_hat(ex->args[1], 0);
- X }
- X sp = makestmt_seq(sp,
- X makestmt_assign(vex,
- X makeexpr_bin(EK_BAND, tp_integer,
- X copyexpr(vex),
- X makeexpr_un(EK_BNOT, tp_integer,
- X makeexpr_bin(EK_LSH, tp_integer,
- X makeexpr_longcast(makeexpr_long(1), 1),
- X makeexpr_unlongcast(ex->args[0]))))));
- X return sp;
- X}
- X
- X
- X
- XStatic Expr *func_na_po2(ex)
- XExpr *ex;
- X{
- X if (!check0_31(ex->args[0]))
- X return ex;
- X return makeexpr_bin(EK_LSH, tp_integer,
- X makeexpr_longcast(makeexpr_long(1), 1),
- X makeexpr_unlongcast(grabarg(ex, 0)));
- X}
- X
- X
- X
- XStatic Expr *func_na_lobits(ex)
- XExpr *ex;
- X{
- X if (!check0_31(ex->args[0]))
- X return ex;
- X return makeexpr_un(EK_BNOT, tp_integer,
- X makeexpr_bin(EK_LSH, tp_integer,
- X makeexpr_longcast(makeexpr_long(-1), 1),
- X makeexpr_unlongcast(grabarg(ex, 0))));
- X}
- X
- X
- X
- XStatic Expr *func_na_hibits(ex)
- XExpr *ex;
- X{
- X if (!check0_31(ex->args[0]))
- X return ex;
- X return makeexpr_bin(EK_LSH, tp_integer,
- X makeexpr_longcast(makeexpr_long(-1), 1),
- X makeexpr_minus(makeexpr_long(32),
- X makeexpr_unlongcast(grabarg(ex, 0))));
- X}
- X
- X
- X
- X/* This function does an arithmetic shift left, or right for negative shift
- X * count. We translate into a C shift only if we are confident of the
- X * sign of the shift count.
- X */
- X
- XStatic Expr *func_na_asl(ex)
- XExpr *ex;
- X{
- X Expr *ex2;
- X
- X ex2 = makeexpr_unlongcast(copyexpr(ex->args[0]));
- X if (expr_is_neg(ex2)) {
- X if (signedshift == 0 || signedshift == 2)
- X return ex;
- X if (possiblesigns(ex2) & 4) {
- X if (assumesigns)
- X note("Assuming count for NA_ASL is negative [504]");
- X else
- X return ex;
- X }
- X if (signedshift != 1)
- X note("Assuming >> is an arithmetic shift [505]");
- X return makeexpr_bin(EK_RSH, tp_integer,
- X grabarg(ex, 1), makeexpr_neg(ex2));
- X } else {
- X if (possiblesigns(ex2) & 1) {
- X if (assumesigns)
- X note("Assuming count for NA_ASL is positive [504]");
- X else
- X return ex;
- X }
- X return makeexpr_bin(EK_LSH, tp_integer, grabarg(ex, 1), ex2);
- X }
- X}
- X
- X
- X
- XStatic Expr *func_na_lsl(ex)
- XExpr *ex;
- X{
- X Expr *ex2;
- X
- X ex2 = makeexpr_unlongcast(copyexpr(ex->args[0]));
- X if (expr_is_neg(ex2)) {
- X if (possiblesigns(ex2) & 4) {
- X if (assumesigns)
- X note("Assuming count for NA_LSL is negative [506]");
- X else
- X return ex;
- X }
- X return makeexpr_bin(EK_RSH, tp_integer,
- X force_unsigned(grabarg(ex, 1)),
- X makeexpr_neg(ex2));
- X } else {
- X if (possiblesigns(ex2) & 1) {
- X if (assumesigns)
- X note("Assuming count for NA_LSL is positive [506]");
- X else
- X return ex;
- X }
- X return makeexpr_bin(EK_LSH, tp_integer, grabarg(ex, 1), ex2);
- X }
- X}
- X
- X
- X
- X/* These bit-field operations were generalized slightly on the way to C;
- X * they used to perform D &= S and now perform D = S1 & S2.
- X */
- X
- XStatic Stmt *proc_na_bfand(ex)
- XExpr *ex;
- X{
- X Stmt *sp;
- X Meaning *tvar;
- X
- X if (!nosideeffects(ex->args[2], 1)) {
- X tvar = makestmttempvar(ex->args[2]->val.type, name_TEMP);
- X sp = makestmt_assign(makeexpr_var(tvar), ex->args[2]);
- X ex->args[2] = makeexpr_var(tvar);
- X } else
- X sp = NULL;
- X insertarg(&ex, 1, copyexpr(ex->args[2]));
- X return makestmt_seq(sp, makestmt_call(ex));
- X}
- X
- X
- X
- XStatic Stmt *proc_na_bfbic(ex)
- XExpr *ex;
- X{
- X return proc_na_bfand(ex);
- X}
- X
- X
- X
- XStatic Stmt *proc_na_bfor(ex)
- XExpr *ex;
- X{
- X return proc_na_bfand(ex);
- X}
- X
- X
- X
- XStatic Stmt *proc_na_bfxor(ex)
- XExpr *ex;
- X{
- X return proc_na_bfand(ex);
- X}
- X
- X
- X
- XStatic Expr *func_imin(ex)
- XExpr *ex;
- X{
- X return makeexpr_bicall_2("P_imin2", tp_integer,
- X ex->args[0], ex->args[1]);
- X}
- X
- X
- X
- XStatic Expr *func_imax(ex)
- XExpr *ex;
- X{
- X return makeexpr_bicall_2("P_imax2", tp_integer,
- X ex->args[0], ex->args[1]);
- X}
- X
- X
- X
- X/* Unsigned non-overflowing arithmetic functions in Pascal; we translate
- X * into plain arithmetic in C and assume C doesn't check for overflow.
- X * (A valid assumption in the case when this was used.)
- X */
- X
- XStatic Expr *func_na_add(ex)
- XExpr *ex;
- X{
- X return makeexpr_plus(makeexpr_unlongcast(ex->args[0]),
- X makeexpr_unlongcast(ex->args[1]));
- X}
- X
- X
- X
- XStatic Expr *func_na_sub(ex)
- XExpr *ex;
- X{
- X return makeexpr_minus(makeexpr_unlongcast(ex->args[0]),
- X makeexpr_unlongcast(ex->args[1]));
- X}
- X
- X
- X
- Xextern Stmt *proc_exit(); /* from funcs.c */
- X
- XStatic Stmt *proc_return()
- X{
- X return proc_exit();
- X}
- X
- X
- X
- XStatic Expr *func_charupper(ex)
- XExpr *ex;
- X{
- X return makeexpr_bicall_1("toupper", tp_char,
- X grabarg(ex, 0));
- X}
- X
- X
- X
- XStatic Expr *func_charlower(ex)
- XExpr *ex;
- X{
- X return makeexpr_bicall_1("tolower", tp_char,
- X grabarg(ex, 0));
- X}
- X
- X
- X
- X/* Convert an integer to its string representation. We produce a sprintf
- X * into a temporary variable; the temporary will probably be eliminated
- X * as the surrounding code is translated.
- X */
- X
- XStatic Expr *func_strint(ex)
- XExpr *ex;
- X{
- X Expr *ex2;
- X
- X ex2 = makeexpr_forcelongness(ex->args[1]);
- X return makeexpr_bicall_3("sprintf", ex->val.type,
- X ex->args[0],
- X makeexpr_string((exprlongness(ex2) > 0) ? "%ld" : "%d"),
- X ex2);
- X}
- X
- X
- X
- XStatic Expr *func_strint2(ex)
- XExpr *ex;
- X{
- X Expr *ex2, *len, *fmt;
- X
- X if (checkconst(ex->args[2], 0) || checkconst(ex->args[2], 1))
- X return func_strint(ex);
- X if (expr_is_neg(ex->args[2])) {
- X if (possiblesigns(ex->args[2]) & 4) {
- X if (assumesigns)
- X note("Assuming width for STRINT2 is negative [507]");
- X else
- X return ex;
- X }
- X ex2 = makeexpr_forcelongness(ex->args[1]);
- X fmt = makeexpr_string((exprlongness(ex2) > 0) ? "%0*ld" : "%0*d");
- X len = makeexpr_neg(makeexpr_longcast(ex->args[2], 0));
- X } else {
- X if (possiblesigns(ex->args[2]) & 1) {
- X if (assumesigns)
- X note("Assuming width for STRINT2 is positive [507]");
- X else
- X return ex;
- X }
- X ex2 = makeexpr_forcelongness(ex->args[1]);
- X fmt = makeexpr_string((exprlongness(ex2) > 0) ? "%*ld" : "%*d");
- X len = makeexpr_longcast(ex->args[2], 0);
- X }
- X ex = makeexpr_bicall_4("sprintf", ex->val.type,
- X ex->args[0], fmt, len, ex2);
- X return cleansprintf(ex);
- X}
- X
- X
- X
- XStatic Expr *func_strhex(ex)
- XExpr *ex;
- X{
- X Expr *ex2, *ex3;
- X Value val;
- X
- X if (isliteralconst(ex->args[2], &val) == 2) {
- X ex2 = makeexpr_forcelongness(ex->args[1]);
- X if (val.i < 1 || val.i > 8) {
- X ex = makeexpr_bicall_3("sprintf", ex->val.type,
- X ex->args[0],
- X makeexpr_string((exprlongness(ex2) > 0) ? "%lX" : "%X"),
- X ex2);
- X } else {
- X if (val.i < 8) {
- X ex3 = makeexpr_long((1 << (val.i*4)) - 1);
- X insertarg(&ex3, 0, makeexpr_name("%#lx", tp_integer));
- X ex2 = makeexpr_bin(EK_BAND, ex2->val.type, ex2, ex3);
- X }
- X ex = makeexpr_bicall_3("sprintf", ex->val.type,
- X ex->args[0],
- X makeexpr_string(format_d((exprlongness(ex2) > 0) ? "%%.%ldlX" :
- X "%%.%ldX",
- X val.i)),
- X ex2);
- X }
- X }
- X return ex;
- X}
- X
- X
- X
- XStatic Expr *func_strreal(ex)
- XExpr *ex;
- X{
- X return makeexpr_bicall_3("sprintf", ex->val.type,
- X ex->args[0],
- X makeexpr_string("%g"),
- X ex->args[1]);
- X}
- X
- X
- X
- XStatic Expr *func_strchar(ex)
- XExpr *ex;
- X{
- X return makeexpr_bicall_3("sprintf", ex->val.type,
- X ex->args[0],
- X makeexpr_string("%c"),
- X ex->args[1]);
- X}
- X
- X
- X
- XStatic Expr *func_strreadint(ex)
- XExpr *ex;
- X{
- X return makeexpr_bicall_3("strtol", tp_integer,
- X grabarg(ex, 0),
- X makeexpr_nil(),
- X makeexpr_long(0));
- X}
- X
- X
- X
- XStatic Expr *func_strreadreal(ex)
- XExpr *ex;
- X{
- X return makeexpr_bicall_1("atof", tp_longreal,
- X grabarg(ex, 0));
- X}
- X
- X
- X
- XStatic Stmt *proc_strappendc(ex)
- XExpr *ex;
- X{
- X Expr *ex2;
- X
- X ex2 = makeexpr_hat(ex->args[0], 0);
- X return makestmt_assign(ex2, makeexpr_concat(copyexpr(ex2), ex->args[1], 0));
- X}
- X
- X
- X
- X/* Check if a string begins with a given prefix; this is easy if the
- X * prefix is known at compile-time.
- X */
- X
- XStatic Expr *func_strbegins(ex)
- XExpr *ex;
- X{
- X Expr *ex1, *ex2;
- X
- X ex1 = ex->args[0];
- X ex2 = ex->args[1];
- X if (ex2->kind == EK_CONST) {
- X if (ex2->val.i == 1) {
- X return makeexpr_rel(EK_EQ,
- X makeexpr_hat(ex1, 0),
- X makeexpr_char(ex2->val.s[0]));
- X } else {
- X return makeexpr_rel(EK_EQ,
- X makeexpr_bicall_3("strncmp", tp_int,
- X ex1,
- X ex2,
- X makeexpr_arglong(makeexpr_long(ex2->val.i), (size_t_long != 0))),
- X makeexpr_long(0));
- X }
- X }
- X return ex;
- X}
- X
- X
- X
- XStatic Expr *func_strcontains(ex)
- XExpr *ex;
- X{
- X return makeexpr_rel(EK_NE,
- X makeexpr_bicall_2("strpbrk", tp_strptr,
- X ex->args[0],
- X ex->args[1]),
- X makeexpr_nil());
- X}
- X
- X
- X
- X/* Extract a substring of a string. If arguments are out-of-range, extract
- X * an empty or shorter substring. Here, the length=infinity and constant
- X * starting index cases are handled specially.
- X */
- X
- XStatic Expr *func_strsub(ex)
- XExpr *ex;
- X{
- X if (isliteralconst(ex->args[3], NULL) == 2 &&
- X ex->args[3]->val.i >= stringceiling) {
- X return makeexpr_bicall_3("sprintf", ex->val.type,
- X ex->args[0],
- X makeexpr_string("%s"),
- X bumpstring(ex->args[1],
- X makeexpr_unlongcast(ex->args[2]), 1));
- X }
- X if (checkconst(ex->args[2], 1)) {
- X return makeexpr_addr(makeexpr_substring(ex->args[0], ex->args[1],
- X ex->args[2], ex->args[3]));
- X }
- X ex->args[2] = makeexpr_arglong(ex->args[2], 0);
- X ex->args[3] = makeexpr_arglong(ex->args[3], 0);
- X return ex;
- X}
- X
- X
- X
- XStatic Expr *func_strpart(ex)
- XExpr *ex;
- X{
- X return func_strsub(ex); /* all the special cases match */
- X}
- X
- X
- X
- XStatic Expr *func_strequal(ex)
- XExpr *ex;
- X{
- X if (!*strcicmpname)
- X return ex;
- X return makeexpr_rel(EK_EQ,
- X makeexpr_bicall_2(strcicmpname, tp_int,
- X ex->args[0], ex->args[1]),
- X makeexpr_long(0));
- X}
- X
- X
- X
- XStatic Expr *func_strcmp(ex)
- XExpr *ex;
- X{
- X return makeexpr_bicall_2("strcmp", tp_int, ex->args[0], ex->args[1]);
- X}
- X
- X
- X
- XStatic Expr *func_strljust(ex)
- XExpr *ex;
- X{
- X return makeexpr_bicall_4("sprintf", ex->val.type,
- X ex->args[0],
- X makeexpr_string("%-*s"),
- X makeexpr_longcast(ex->args[2], 0),
- X ex->args[1]);
- X}
- X
- X
- X
- XStatic Expr *func_strrjust(ex)
- XExpr *ex;
- X{
- X return makeexpr_bicall_4("sprintf", ex->val.type,
- X ex->args[0],
- X makeexpr_string("%*s"),
- X makeexpr_longcast(ex->args[2], 0),
- X ex->args[1]);
- X}
- X
- X
- X
- X
- X/* The procedure strnew(p,s) is converted into an assignment p = strdup(s). */
- X
- XStatic Stmt *proc_strnew(ex)
- XExpr *ex;
- X{
- X return makestmt_assign(makeexpr_hat(ex->args[0], 0),
- X makeexpr_bicall_1("strdup", ex->args[1]->val.type,
- X ex->args[1]));
- X}
- X
- X
- X
- X/* These procedures are also changed to functions returning a result. */
- X
- XStatic Stmt *proc_strlist_add(ex)
- XExpr *ex;
- X{
- X return makestmt_assign(makeexpr_hat(ex->args[1], 0),
- X makeexpr_bicall_2("strlist_add", ex->args[0]->val.type->basetype,
- X ex->args[0],
- X ex->args[2]));
- X}
- X
- X
- X
- XStatic Stmt *proc_strlist_append(ex)
- XExpr *ex;
- X{
- X return makestmt_assign(makeexpr_hat(ex->args[1], 0),
- X makeexpr_bicall_2("strlist_append", ex->args[0]->val.type->basetype,
- X ex->args[0],
- X ex->args[2]));
- X}
- X
- X
- X
- XStatic Stmt *proc_strlist_insert(ex)
- XExpr *ex;
- X{
- X return makestmt_assign(makeexpr_hat(ex->args[1], 0),
- X makeexpr_bicall_2("strlist_insert", ex->args[0]->val.type->basetype,
- X ex->args[0],
- X ex->args[2]));
- X}
- X
- X
- X
- X
- X
- X
- X
- X
- X
- X/* NEWCI functions */
- X
- X
- XStatic Stmt *proc_fixfname(ex)
- XExpr *ex;
- X{
- X if (ex->args[1]->kind == EK_CONST)
- X lwc(ex->args[1]->val.s); /* Unix uses lower-case suffixes */
- X return makestmt_call(ex);
- X}
- X
- X
- XStatic Stmt *proc_forcefname(ex)
- XExpr *ex;
- X{
- X return proc_fixfname(ex);
- X}
- X
- X
- X/* In Pascal these were variables of type pointer-to-text; we translate
- X * them as, e.g., &stdin. Note that even though &stdin is not legal in
- X * many systems, in the common usage of writeln(stdin^) the & will
- X * cancel out in a later stage of the translation.
- X */
- X
- XStatic Expr *func_stdin()
- X{
- X return makeexpr_addr(makeexpr_var(mp_input));
- X}
- X
- X
- XStatic Expr *func_stdout()
- X{
- X return makeexpr_addr(makeexpr_var(mp_output));
- X}
- X
- X
- XStatic Expr *func_stderr()
- X{
- X return makeexpr_addr(makeexpr_name("stderr", tp_text));
- X}
- X
- X
- X
- X
- X
- X
- X
- X
- X/* MYLIB functions */
- X
- X
- XStatic Stmt *proc_m_color(ex)
- XExpr *ex;
- X{
- X int i;
- X long val;
- X
- X if (ex->kind == EK_PLUS) {
- X for (i = 0; i < ex->nargs; i++) {
- X if (isconstexpr(ex->args[i], &val)) {
- X if (val > 0 && (val & 15) == 0) {
- X note("M_COLOR called with suspicious argument [508]");
- X }
- X }
- X }
- X } else if (ex->kind == EK_CONST) {
- X if (ex->val.i >= 16 && ex->val.i < 255) { /* accept true colors and m_trans */
- X note("M_COLOR called with suspicious argument [508]");
- X }
- X }
- X return makestmt_call(ex);
- X}
- X
- X
- X
- X
- X
- X
- X
- Xvoid citmods(name, defn)
- Xchar *name;
- Xint defn;
- X{
- X if (!strcmp(name, "NEWASM")) {
- X makestandardproc("na_fillbyte", proc_na_fillbyte);
- X makestandardproc("na_fill", proc_na_fill);
- X makestandardproc("na_fillp", proc_na_fill);
- X makestandardproc("na_move", proc_na_move);
- X makestandardproc("na_movep", proc_na_move);
- X makestandardproc("na_exch", proc_na_exch);
- X makestandardproc("na_exchp", proc_na_exch);
- X makestandardfunc("na_comp", func_na_comp);
- X makestandardfunc("na_compp", func_na_comp);
- X makestandardfunc("na_scaneq", func_na_scaneq);
- X makestandardfunc("na_scaneqp", func_na_scaneq);
- X makestandardfunc("na_scanne", func_na_scanne);
- X makestandardfunc("na_scannep", func_na_scanne);
- X makestandardproc("na_new", proc_na_new);
- X makestandardproc("na_dispose", proc_na_dispose);
- X makestandardproc("na_alloc", proc_na_alloc);
- X makestandardproc("na_outeralloc", proc_na_outeralloc);
- X makestandardproc("na_free", proc_na_free);
- X makestandardfunc("na_memavail", func_na_memavail);
- X makestandardfunc("na_and", func_na_and);
- X makestandardfunc("na_bic", func_na_bic);
- X makestandardfunc("na_or", func_na_or);
- X makestandardfunc("na_xor", func_na_xor);
- X makestandardfunc("na_not", func_na_not);
- X makestandardfunc("na_mask", func_na_mask);
- X makestandardfunc("na_test", func_na_test);
- X makestandardproc("na_set", proc_na_set);
- X makestandardproc("na_clear", proc_na_clear);
- X makestandardfunc("na_po2", func_na_po2);
- X makestandardfunc("na_hibits", func_na_hibits);
- X makestandardfunc("na_lobits", func_na_lobits);
- X makestandardfunc("na_asl", func_na_asl);
- X makestandardfunc("na_lsl", func_na_lsl);
- X makestandardproc("na_bfand", proc_na_bfand);
- X makestandardproc("na_bfbic", proc_na_bfbic);
- X makestandardproc("na_bfor", proc_na_bfor);
- X makestandardproc("na_bfxor", proc_na_bfxor);
- X makestandardfunc("imin", func_imin);
- X makestandardfunc("imax", func_imax);
- X makestandardfunc("na_add", func_na_add);
- X makestandardfunc("na_sub", func_na_sub);
- X makestandardproc("return", proc_return);
- X makestandardfunc("charupper", func_charupper);
- X makestandardfunc("charlower", func_charlower);
- X makestandardfunc("strint", func_strint);
- X makestandardfunc("strint2", func_strint2);
- X makestandardfunc("strhex", func_strhex);
- X makestandardfunc("strreal", func_strreal);
- X makestandardfunc("strchar", func_strchar);
- X makestandardfunc("strreadint", func_strreadint);
- X makestandardfunc("strreadreal", func_strreadreal);
- X makestandardproc("strappendc", proc_strappendc);
- X makestandardfunc("strbegins", func_strbegins);
- X makestandardfunc("strcontains", func_strcontains);
- X makestandardfunc("strsub", func_strsub);
- X makestandardfunc("strpart", func_strpart);
- X makestandardfunc("strequal", func_strequal);
- X makestandardfunc("strcmp", func_strcmp);
- X makestandardfunc("strljust", func_strljust);
- X makestandardfunc("strrjust", func_strrjust);
- X makestandardproc("strnew", proc_strnew);
- X makestandardproc("strlist_add", proc_strlist_add);
- X makestandardproc("strlist_append", proc_strlist_append);
- X makestandardproc("strlist_insert", proc_strlist_insert);
- X } else if (!strcmp(name, "NEWCI")) {
- X makestandardproc("fixfname", proc_fixfname);
- X makestandardproc("forcefname", proc_forcefname);
- X makestandardfunc("stdin", func_stdin);
- X makestandardfunc("stdout", func_stdout);
- X makestandardfunc("stderr", func_stderr);
- X } else if (!strcmp(name, "MYLIB")) {
- X makestandardproc("m_color", proc_m_color);
- X }
- X}
- X
- X
- X
- X
- X/* End. */
- X
- X
- X
- END_OF_FILE
- if test 31407 -ne `wc -c <'src/citmods.c'`; then
- echo shar: \"'src/citmods.c'\" unpacked with wrong size!
- fi
- # end of 'src/citmods.c'
- fi
- echo shar: End of archive 10 \(of 32\).
- cp /dev/null ark10isdone
- MISSING=""
- for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 ; do
- if test ! -f ark${I}isdone ; then
- MISSING="${MISSING} ${I}"
- fi
- done
- if test "${MISSING}" = "" ; then
- echo You have unpacked all 32 archives.
- echo "Now see PACKNOTES and the README"
- rm -f ark[1-9]isdone ark[1-9][0-9]isdone
- else
- echo You still need to unpack the following archives:
- echo " " ${MISSING}
- fi
- ## End of shell archive.
- exit 0
-