home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Black Box 4
/
BlackBox.cdr
/
progpas
/
pxsc.arj
/
P88RTS.H
< prev
next >
Wrap
Text File
|
1991-03-12
|
21KB
|
602 lines
/* file: p88rts.h
* Header File of the PASCAL 88 to C runtime system
{* last modification: 18.02.91 11:57 }
* uli 05.02.91: s_ixcn defined.
* uli 05.02.91: tp_000 is no longer static.
* uli 18.02.91: tp_000 is extern now.
*/
#define LINT_ARGS /* new-style prototyping */
#define IBMva /* IBM style variable argument lists */
#define a_RETC 0 /* value returned by main (default) */
/*---------------------------------------------------*/
/* global pointer variable, used by var-traversing */
/*---------------------------------------------------*/
extern char *tp_000;
/*----------------------------------------------*/
/* Number of characters forming a set value */
/*----------------------------------------------*/
#define s_SIZE 32
/*--------------------------------------*/
/* standard data types of Pascal-SC */
/*--------------------------------------*/
typedef unsigned char a_byte ;
#ifdef LINT_ARGS
typedef void * a_VOID ;
#else
typedef char * a_VOID ;
#endif
typedef long int a_intg ; /* adjust a_imax, if you modify a_intg */
typedef double a_real ;
typedef unsigned char a_char ;
typedef a_byte a_bool ;
typedef unsigned long a_btyp ;
typedef struct s_trng { char *ptr;
size_t alen;
size_t clen;
unsigned int fix : 1;
unsigned int suba : 1;
unsigned int tmp : 1; } s_trng;
typedef a_char s_etof [s_SIZE];
typedef a_btyp * d_otpr ;
typedef struct a_cmpx { a_real RE , IM; } a_cmpx ;
typedef struct a_intv { a_real INF, SUP;} a_intv ;
typedef struct a_cinv { a_intv RE , IM ;} a_cinv ;
/*----------------------------------------*/
/* error handling, exception handling */
/*----------------------------------------*/
extern int e_line ;
#ifdef LINT_ARGS
#ifdef IBMva
extern void e_trap () ;
#else
extern void e_trap (a_btyp code, int e_argc, ...) ;
#endif
extern void e_push (char * functionname, char * filename) ;
extern void e_popp (void) ;
#else
extern void e_trap () ;
extern void e_push ( ) ;
extern void e_popp ( ) ;
#endif
/*-------------------------------------*/
/* standard constants of Pascal-SC */
/*-------------------------------------*/
#define a_true 1
#define a_flse 0
#define a_imax 0x7fffffff /* = MAXINT */
/*--------------------------*/
/* Real constant conversion */
/*--------------------------*/
#ifdef LINT_ARGS
extern a_real r_cnst (a_char*) ;
#else
extern a_real r_cnst () ;
#endif
/*-----------------------*/
/* Memory management */
/*-----------------------*/
#define a_asgn(s1,s2,c) memcpy((s1),(s2),(c))
#define a_clrm(s,c) memset((s),0,(c))
#ifdef LINT_ARGS
extern a_VOID a_lloc (size_t) ; /* malloc + errorhandling */
extern void a_free (char **) ; /* free + errorhandling */
#else
extern a_VOID a_lloc () ;
extern void a_free () ;
#endif
/*--------------------*/
/* Set Operations */
/*--------------------*/
#ifdef LINT_ARGS
extern a_bool s_etin (a_intg, s_etof) ; /* operator "in" */
extern a_VOID /* s_etof */ s_zero (s_etof) ; /* empty set constructor [] */
#ifdef IBMva
extern a_VOID /* s_etof */ s_cons () ; /* set constructor */
#else
extern a_VOID s_cons (s_etof res, a_char * ctrl,...); /* set constructor */
#endif
extern a_VOID /* s_etof */ s_add (s_etof, s_etof, s_etof); /* set = set + set */
extern a_VOID /* s_etof */ s_sub (s_etof, s_etof, s_etof); /* set = set - set */
extern a_VOID /* s_etof */ s_mul (s_etof, s_etof, s_etof); /* set = set * set */
extern a_bool s_eteq (s_etof, s_etof); /* set == set */
extern a_bool s_etne (s_etof, s_etof); /* set != set */
extern a_bool s_etge (s_etof, s_etof); /* set >= set */
extern a_bool s_etgt (s_etof, s_etof); /* set > set */
extern a_bool s_etle (s_etof, s_etof); /* set <= set */
extern a_bool s_etlt (s_etof, s_etof); /* set < set */
#else
extern a_bool s_etin () ; /* operator "in" */
extern a_VOID s_zero () ; /* empty set constructor [] */
extern a_VOID s_cons () ; /* set constructor */
extern a_VOID /* s_etof */ s_add (); /* set = set + set */
extern a_VOID /* s_etof */ s_sub (); /* set = set - set */
extern a_VOID /* s_etof */ s_mul (); /* set = set * set */
extern a_bool s_eteq (); /* set == set */
extern a_bool s_etne (); /* set != set */
extern a_bool s_etge (); /* set >= set */
extern a_bool s_etgt (); /* set > set */
extern a_bool s_etle (); /* set <= set */
extern a_bool s_etlt (); /* set < set */
#endif
/*-----------------------*/
/* String Operations */
/*-----------------------*/
#define s_inxn( s, i) (*((s).ptr + (i) - 1)) /* index access without check */
#define s_asta( d, s, l) s_asgn ((s_trng*)(d), s_stat ((s), (l)))
/* assigns a static array to a dynamic array */
#ifdef LINT_ARGS
extern a_intg s_ixch (a_intg index, size_t length) ;
extern a_char * s_inxc (s_trng, a_intg) ; /* index access with check */
/* (*((s).ptr + s_ixch((i),(s).alen))) */
/* s_inxc must not be a macro, because the string variable s may */
/* contain indices with function calls. */
/* s_inxc must return a pointer, because it must be a left-value. */
extern a_char * s_ixcn (s_trng*, a_intg) ; /* index access with check */
/* s_ixcn must have a var parameter, because "resize" might be necessary */
extern a_bool s_aaeq (a_char[], a_intg, a_char[], a_intg );
extern a_bool s_aceq (a_char[], a_intg, a_char );
extern a_bool s_caeq (a_char , a_char[], a_intg );
extern a_bool s_aane (a_char[], a_intg, a_char[], a_intg );
extern a_bool s_acne (a_char[], a_intg, a_char );
extern a_bool s_cane (a_char , a_char[], a_intg );
extern a_bool s_aage (a_char[], a_intg, a_char[], a_intg );
extern a_bool s_acge (a_char[], a_intg, a_char );
extern a_bool s_cage (a_char , a_char[], a_intg );
extern a_bool s_aagt (a_char[], a_intg, a_char[], a_intg );
extern a_bool s_acgt (a_char[], a_intg, a_char );
extern a_bool s_cagt (a_char , a_char[], a_intg );
extern a_bool s_aale (a_char[], a_intg, a_char[], a_intg );
extern a_bool s_acle (a_char[], a_intg, a_char );
extern a_bool s_cale (a_char , a_char[], a_intg );
extern a_bool s_aalt (a_char[], a_intg, a_char[], a_intg );
extern a_bool s_aclt (a_char[], a_intg, a_char );
extern a_bool s_calt (a_char , a_char[], a_intg );
extern a_bool s_sseq (s_trng, s_trng);
extern a_bool s_sceq (s_trng, a_char);
extern a_bool s_cseq (a_char, s_trng );
extern a_bool s_ssne (s_trng, s_trng );
extern a_bool s_scne (s_trng, a_char);
extern a_bool s_csne (a_char, s_trng );
extern a_bool s_ssge (s_trng, s_trng );
extern a_bool s_scge (s_trng, a_char);
extern a_bool s_csge (a_char, s_trng );
extern a_bool s_ssgt (s_trng, s_trng );
extern a_bool s_scgt (s_trng, a_char);
extern a_bool s_csgt (a_char, s_trng );
extern a_bool s_ssle (s_trng, s_trng );
extern a_bool s_scle (s_trng, a_char);
extern a_bool s_csle (a_char, s_trng );
extern a_bool s_sslt (s_trng, s_trng );
extern a_bool s_sclt (s_trng, a_char);
extern a_bool s_cslt (a_char, s_trng );
extern void s_vlcp (s_trng *);
extern void s_utmp (s_trng *);
extern void s_temp (s_trng *);
extern s_trng s_stat (a_char [], a_intg);
extern void s_init (s_trng *,size_t);
extern void s_free (s_trng *);
extern s_trng s_conc (s_trng, s_trng);
extern s_trng s_char (a_char);
extern void s_asgn (s_trng *,s_trng);
#else
/* not LINT_ARGS */
extern a_intg s_ixch () ;
extern a_char *s_inxc ();
extern a_char *s_ixcn () ;
extern a_bool s_aaeq ();
extern a_bool s_aceq ();
extern a_bool s_caeq ();
extern a_bool s_aane ();
extern a_bool s_acne ();
extern a_bool s_cane ();
extern a_bool s_aage ();
extern a_bool s_acge ();
extern a_bool s_cage ();
extern a_bool s_aagt ();
extern a_bool s_acgt ();
extern a_bool s_cagt ();
extern a_bool s_aale ();
extern a_bool s_acle ();
extern a_bool s_cale ();
extern a_bool s_aalt ();
extern a_bool s_aclt ();
extern a_bool s_calt ();
extern a_bool s_sseq ();
extern a_bool s_sceq ();
extern a_bool s_cseq ();
extern a_bool s_ssne ();
extern a_bool s_scne ();
extern a_bool s_csne ();
extern a_bool s_ssge ();
extern a_bool s_scge ();
extern a_bool s_csge ();
extern a_bool s_ssgt ();
extern a_bool s_scgt ();
extern a_bool s_csgt ();
extern a_bool s_ssle ();
extern a_bool s_scle ();
extern a_bool s_csle ();
extern a_bool s_sslt ();
extern a_bool s_sclt ();
extern a_bool s_cslt ();
extern void s_vlcp ();
extern void s_utmp ();
extern void s_temp ();
extern s_trng s_stat ();
extern void s_init ();
extern void s_free ();
extern s_trng s_conc ();
extern s_trng s_char ();
extern void s_asgn ();
#endif
/* end not LINT_ARGS */
/*-------------------------------------*/
/* Scalar product for static arrays */
/*-------------------------------------*/
#ifdef LINT_ARGS
extern a_real r_scps (a_real x[], a_real y[], a_intg size, a_intg rdmode) ;
#else
extern a_real r_scps () ;
#endif
/*------------------------------*/
/* dotprecision routines */
/*------------------------------*/
#ifdef LINT_ARGS
extern void d_init (d_otpr * ) ;
extern void d_vlcp (d_otpr * ) ;
extern void d_free (d_otpr * ) ;
extern void d_temp (d_otpr * ) ;
extern void d_utmp (d_otpr * ) ;
#else
extern void d_init () ;
extern void d_vlcp () ;
extern void d_free () ;
extern void d_temp () ;
extern void d_utmp () ;
#endif
/*------------------------------*/
/* routines for #-expressions */
/*------------------------------*/
#ifdef LINT_ARGS
void c_cadd(d_otpr *cr,d_otpr *ci,a_cmpx a);
void c_csub(d_otpr *cr,d_otpr *ci,a_cmpx a);
void c_padd(d_otpr *cr,d_otpr *ci,a_cmpx a,a_cmpx b);
void c_psub(d_otpr *cr,d_otpr *ci,a_cmpx a,a_cmpx b);
void c_rcad(d_otpr *cr,d_otpr *ci,a_real a,a_cmpx b);
void c_rcsb(d_otpr *cr,d_otpr *ci,a_real a,a_cmpx b);
a_cmpx c_stad(d_otpr cr,d_otpr ci);
a_cmpx c_stan(d_otpr cr,d_otpr ci);
a_cmpx c_stau(d_otpr cr,d_otpr ci);
void d_ass(d_otpr *a,d_otpr b);
void d_clr(d_otpr *a);
void d_dadd(d_otpr *a,d_otpr b);
void d_dsub(d_otpr *a,d_otpr b);
a_bool d_eq(d_otpr a,d_otpr b);
void d_free(d_otpr *a);
a_bool d_ge(d_otpr a,d_otpr b);
a_bool d_gt(d_otpr a,d_otpr b);
void d_init(d_otpr *a);
a_bool d_le(d_otpr a,d_otpr b);
a_bool d_lt(d_otpr a,d_otpr b);
a_bool d_ne(d_otpr a,d_otpr b);
void d_padd(d_otpr *c,a_real a,a_real b);
void d_psub(d_otpr *c,a_real a,a_real b);
void d_radd(d_otpr *c,a_real a);
void d_rsub(d_otpr *c,a_real a);
a_real d_stad(d_otpr a);
a_real d_stan(d_otpr a);
a_real d_stau(d_otpr a);
void i_iadd(d_otpr *cl,d_otpr *cu,a_intv a);
a_intv i_ista(d_otpr cl,d_otpr cu);
void i_isub(d_otpr *cl,d_otpr *cu,a_intv a);
void i_padd(d_otpr *cl,d_otpr *cu,a_intv a,a_intv b);
void i_psub(d_otpr *cl,d_otpr *cu,a_intv a,a_intv b);
void i_riad(d_otpr *cl,d_otpr *cu,a_real a,a_intv b);
void i_risb(d_otpr *cl,d_otpr *cu,a_real a,a_intv b);
void z_ciad(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_cmpx a,a_intv b);
void z_cisb(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_cmpx a,a_intv b);
void z_czad(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_cmpx a,a_cinv b);
void z_czsb(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_cmpx a,a_cinv b);
void z_izad(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_intv a,a_cinv b);
void z_izsb(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_intv a,a_cinv b);
void z_padd(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_cinv a,a_cinv b);
void z_psub(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_cinv a,a_cinv b);
void z_rzad(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_real a,a_cinv b);
void z_rzsb(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_real a,a_cinv b);
void z_zadd(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_cinv a);
a_cinv z_zsta(d_otpr crl,d_otpr cil,d_otpr cru,d_otpr ciu);
void z_zsub(d_otpr *crl,d_otpr *cil,d_otpr *cru,d_otpr *ciu,a_cinv a);
#else
a_cinv z_zsta();
a_cmpx c_stad(), c_stan(), c_stau();
a_intv i_ista();
a_real d_stad(), d_stan(), d_stau();
a_bool d_eq(), d_ge(), d_gt(), d_le(), d_lt(), d_ne();
void c_cadd(), c_csub(), c_padd(), c_psub(), c_rcad(), c_rcsb(),
d_ass(), d_clr(), d_dadd(), d_dsub(), d_free(), d_init(),
d_padd(), d_psub(), d_radd(), d_rsub(), i_iadd(), i_isub(),
i_padd(), i_psub(), i_riad(), i_risb(), z_ciad(), z_cisb(),
z_czad(), z_czsb(), z_izad(), z_izsb(), z_padd(), z_psub(),
z_rzad(), z_rzsb(), z_zadd(), z_zsub();
#endif
/*--------------------*/
/* Runtime Checks */
/*--------------------*/
#ifdef LINT_ARGS
extern a_btyp a_ixch (a_intg index, a_intg lb, a_intg ub) ; /* Index Check */
/* returns index - lb */
extern a_VOID a_nilc (a_VOID pointer) ; /* Pointer Check */
/* returns pointer */
#else
extern a_btyp a_ixch ( ) ;
extern a_VOID a_nilc ( ) ;
#endif
/*--------------------*/
/* Dynamic Arrays */
/*--------------------*/
/* Array descriptor */
typedef struct {
a_intg lbound, ubound;
size_t stride ;
} y_bnds ;
#define y_arof( typ, dim) \
struct \
{ typ * array ; \
a_byte subarr ; \
a_byte destroy ; \
a_byte numdim ; \
size_t elsize ; \
size_t elnum ; \
y_bnds fd [dim] ; \
}
#ifdef LINT_ARGS
/* #define descrtype y_arof (void, 255) */
typedef y_arof (void, 255) y_desc ;
/* The typedef may cause an error message */
typedef y_desc descrtype ;
/* Stride initialization */
extern void y_init (y_desc * d, a_byte dim, size_t elsize) ;
extern void y_free (y_desc * d) ;
#else
/* #define descrtype y_arof (char, 255) */
typedef y_arof(char, 255) y_desc ;
typedef y_desc descrtype ;
extern void y_init () ;
extern void y_free () ;
#endif
#define y_lbnd(d,n) ((d)->fd[(n)-1].lbound)
#define y_ubnd(d,n) ((d)->fd[(n)-1].ubound)
/* Array access without indexcheck*/
#define y_inx1( d, i) \
(*( (d).array + ((i) - (d).fd[0].lbound) * (d).fd[0].stride \
)) /* vector */
#define y_inx2( d, i, j) \
(*( (d).array + ((i) - (d).fd[0].lbound) * (d).fd[0].stride \
+ ((j) - (d).fd[1].lbound) * (d).fd[1].stride \
)) /* matrix */
#define y_inx3( d, i, j, k) \
(*( (d).array + ((i) - (d).fd[0].lbound) * (d).fd[0].stride \
+ ((j) - (d).fd[1].lbound) * (d).fd[1].stride \
+ ((k) - (d).fd[2].lbound) * (d).fd[2].stride \
)) /* tensor */
/* later, if a dynamic array may be component variable, then */
/* side effects in d become dangerous. d has to be a value parameter. */
/* Array access with indexcheck*/
#define y_ixc1( d, i) \
(*((d).array + y_ixch ((i), (d).fd[0]) )) /* vector */
#define y_ixc2( d, i, j) \
(*((d).array + y_ixch ((i), (d).fd[0]) + y_ixch ((j), (d).fd[1]) ))
/* matrix */
#define y_ixc3( d, i, j, k) \
(*((d).array + y_ixch ((i), (d).fd[0]) + y_ixch ((j), (d).fd[1]) \
+ y_ixch ((k), (d).fd[2]) )) /* tensor */
/* Array access for #-expressions */
/* Array access without indexcheck*/
#define y_ynx1( d, i) \
(*( (d).array + ((i)) * (d).fd[0].stride \
)) /* vector */
#define y_ynx2( d, i, j) \
(*( (d).array + ((i) ) * (d).fd[0].stride \
+ ((j) ) * (d).fd[1].stride \
)) /* matrix */
#define y_ynx3( d, i, j, k) \
(*( (d).array + ((i) ) * (d).fd[0].stride \
+ ((j) ) * (d).fd[1].stride \
+ ((k) ) * (d).fd[2].stride \
)) /* tensor */
/* later, if a dynamic array may be component variable, then */
/* side effects in d become dangerous. d has to be a value parameter. */
/* Array access with indexcheck*/
#define y_yxc1( d, i) \
(*((d).array + y_yxch ((i), (d).fd[0]) )) /* vector */
#define y_yxc2( d, i, j) \
(*((d).array + y_yxch ((i), (d).fd[0]) + y_yxch ((j), (d).fd[1]) ))
/* matrix */
#define y_yxc3( d, i, j, k) \
(*((d).array + y_yxch ((i), (d).fd[0]) + y_yxch ((j), (d).fd[1]) \
+ y_yxch ((k), (d).fd[2]) )) /* tensor */
#ifdef LINT_ARGS
/* Index check */
extern a_btyp y_ixch (a_intg index, y_bnds bounds) ;
extern a_btyp y_yxch (a_intg index, y_bnds bounds) ;
/* Dynamic array assignment */
extern void y_asgn (y_desc * target, y_desc * source) ;
extern void y_vlcp (y_desc * ) ;
extern void y_temp (y_desc * ) ;
extern void y_utmp (y_desc * ) ;
#ifdef IBMva
extern a_VOID y_inxn( ) ;
extern a_VOID y_ixcn( ) ;
extern a_VOID y_suba( ) ;
extern a_VOID y_stat( ) ;
extern a_VOID y_ynxn( ) ;
extern a_VOID y_yxcn( ) ;
#else
/*--------------*/
/* Array access */
extern a_VOID y_inxn (y_desc * ,...) ; /* without Index check */
extern a_VOID y_ixcn (y_desc * ,...) ; /* with Index check */
/* Subarray access: */
/* Subarray descriptor generation */
extern a_VOID y_suba (y_desc * md, y_desc * sd,
a_char * mode ,... ) ;
/* convert static to dynamic array */
extern a_VOID y_stat (y_desc * d, a_VOID statarray, size_t elsize,
a_byte dim, ...) ;
extern a_VOID y_ynxn (y_desc * ,...) ; /* without Index check */
extern a_VOID y_yxcn (y_desc * ,...) ; /* with Index check */
#endif
#else
extern a_btyp y_ixch () ;
extern a_btyp y_yxch () ;
extern a_VOID y_inxn () ;
extern a_VOID y_ixcn () ;
extern void y_asgn () ;
extern void y_vlcp () ;
extern void y_temp () ;
extern void y_utmp () ;
extern a_VOID y_stat () ;
extern a_VOID y_ynxn () ;
extern a_VOID y_yxcn () ;
extern a_VOID y_suba () ;
#endif
/*-----------------*/
/* File Handling */
/*-----------------*/
#define f_fnsz 64
/* Filedescriptor */
#define f_ilof(typ) struct {\
FILE * fp ;\
unsigned eof : 1 ;\
unsigned eoln : 1 ;\
unsigned text : 1 ;\
unsigned infl : 1 ;\
unsigned outf : 1 ;\
unsigned stdi : 1 ;\
unsigned stdo : 1 ;\
unsigned asgd : 1 ;\
unsigned err : 1 ;\
unsigned temp : 1 ;\
size_t ellen ;\
char name[f_fnsz] ;\
char *org;\
union {\
double f; /* forces alignm */\
typ dow ;\
char ch [sizeof (typ)] ;\
} win ;\
}
typedef f_ilof (a_char) f_text ;
extern f_text f_inpu, f_outp ;
#ifdef LINT_ARGS
extern void f_init (int argc, char ** argv) ;
extern void f_assg (f_text * filevar, char * filename, size_t ellen) ;
extern void f_eofp (void) ;
extern void f_rset (f_text*, char *, a_char *) ;
extern void f_rwri (f_text*, char *, a_char *) ;
extern void f_get_ (f_text*) ;
extern void f_put_ (f_text*) ;
extern void f_read (f_text*, a_VOID) ;
extern void f_writ (f_text*, a_VOID) ;
extern void f_wrc1 (f_text*, a_char *, a_intg) ;
extern void f_wrc2 (f_text*, a_char *, a_intg, a_intg) ;
extern void f_free (f_text*) ;
#else
extern void f_init ( ) ;
extern void f_assg ( ) ;
extern void f_eofp ( ) ;
extern void f_rset ( ) ;
extern void f_rwri ( ) ;
extern void f_get_ ( ) ;
extern void f_put_ ( ) ;
extern void f_read ( ) ;
extern void f_writ ( ) ;
extern void f_wrc1 ( ) ;
extern void f_wrc2 ( ) ;
extern void f_free ( ) ;
#endif
/*-----------------------------------------------*/
/* standard dynamic array types of Pascal-SC */
/*-----------------------------------------------*/
typedef y_arof (a_real,1) a_rvty ;
typedef y_arof (a_cmpx,1) a_cvty ;
typedef y_arof (a_intv,1) a_ivty ;
typedef y_arof (a_cinv,1) a_civt ;
typedef y_arof (a_real,2) a_rmty ;
typedef y_arof (a_cmpx,2) a_cmty ;
typedef y_arof (a_intv,2) a_imty ;
typedef y_arof (a_cinv,2) a_cimt ;
/*-----------------------*/
/* Standard functions: */
/*-----------------------*/
#define a_chr_ (a_char)
#define a_odd_(x) (1&(x))