rsalz@uunet.uu.net (Rich Salz) (03/28/90)
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 -- Please send comp.sources.unix-related mail to rsalz@uunet.uu.net. Use a domain-based address or give alternate paths, or you may lose out.