brennan@ssc-vax.UUCP (Mike Brennan) (05/11/91)
------------------cut here----------------
{ case C_NOINIT : cp->dval = 0.0 ; break ;
case C_DOUBLE : goto two ;
case C_STRNUM :
free_STRING( string(cp) ) ;
break ;
case C_MBSTRN :
case C_STRING :
s = (STRING *) cp->ptr ;
#if FPE_TRAPS /* look for overflow error */
errno = 0 ;
cp->dval = strtod(s->str,(char **)0) ;
if ( errno && cp->dval != 0.0 ) /* ignore underflow */
rt_error("overflow converting %s to double", s) ;
#else
cp->dval = strtod(s->str,(char **)0) ;
#endif
free_STRING(s) ;
break ;
default :
bozo("cast on bad type") ;
}
cp->type = C_DOUBLE ;
two: cp++ ;
switch( cp->type )
{ case C_NOINIT : cp->dval = 0.0 ; break ;
case C_DOUBLE : return ;
case C_STRNUM :
free_STRING( string(cp) ) ;
break ;
case C_MBSTRN :
case C_STRING :
s = (STRING *) cp->ptr ;
#if FPE_TRAPS /* look for overflow error */
errno = 0 ;
cp->dval = strtod(s->str,(char **)0) ;
if ( errno && cp->dval != 0.0 ) /* ignore underflow */
rt_error("overflow converting %s to double", s) ;
#else
cp->dval = strtod(s->str,(char **)0) ;
#endif
free_STRING(s) ;
break ;
default :
bozo("cast on bad type") ;
}
cp->type = C_DOUBLE ;
}
void cast1_to_s( cp )
register CELL *cp ;
{
switch( cp->type )
{ case C_NOINIT :
null_str.ref_cnt++ ;
cp->ptr = (PTR) &null_str ;
break ;
case C_DOUBLE :
(void) sprintf(temp_buff.string_buff ,
string(field+OFMT)->str, cp->dval) ;
cp->ptr = (PTR) new_STRING(temp_buff.string_buff) ;
break ;
case C_STRING : return ;
case C_MBSTRN :
case C_STRNUM : break ;
default : bozo("bad type on cast") ;
}
cp->type = C_STRING ;
}
void cast2_to_s( cp )
register CELL *cp ;
{
switch( cp->type )
{ case C_NOINIT :
null_str.ref_cnt++ ;
cp->ptr = (PTR) &null_str ;
break ;
case C_DOUBLE :
(void) sprintf(temp_buff.string_buff,
string(field+OFMT)->str, cp->dval ) ;
cp->ptr = (PTR) new_STRING(temp_buff.string_buff) ;
break ;
case C_STRING : goto two ;
case C_MBSTRN :
case C_STRNUM : break ;
default : bozo("bad type on cast") ;
}
cp->type = C_STRING ;
two:
cp++ ;
switch( cp->type )
{ case C_NOINIT :
null_str.ref_cnt++ ;
cp->ptr = (PTR) &null_str ;
break ;
case C_DOUBLE :
(void) sprintf(temp_buff.string_buff,
string(field+OFMT)->str, cp->dval) ;
cp->ptr = (PTR) new_STRING(temp_buff.string_buff) ;
break ;
case C_STRING : return ;
case C_MBSTRN :
case C_STRNUM : break ;
default : bozo("bad type on cast") ;
}
cp->type = C_STRING ;
}
void cast_to_RE( cp )
register CELL *cp ;
{ register PTR p ;
if ( cp->type < C_STRING ) cast1_to_s(cp) ;
p = re_compile( string(cp) ) ;
free_STRING( string(cp) ) ;
cp->type = C_RE ;
cp->ptr = p ;
}
void cast_for_split(cp)
register CELL *cp ;
{
static char meta[] = "^$.*+?|[]()" ;
static char xbuff[] = "\\X" ;
int c ;
unsigned len ;
if ( cp->type < C_STRING ) cast1_to_s(cp) ;
if ( (len = string(cp)->len) == 1 )
{
if ( (c = string(cp)->str[0]) == ' ' )
{ free_STRING(string(cp)) ;
cp->type = C_SPACE ;
return ;
}
else
if ( strchr(meta, c) )
{ xbuff[1] = c ;
free_STRING(string(cp)) ;
cp->ptr = (PTR) new_STRING(xbuff) ;
}
}
else
if ( len == 0 )
{ free_STRING(string(cp)) ;
cp->type = C_SNULL ;
return ;
}
cast_to_RE(cp) ;
}
/* input: cp-> a CELL of type C_MBSTRN (maybe strnum)
test it -- casting it to the appropriate type
which is C_STRING or C_STRNUM
*/
void check_strnum( cp )
CELL *cp ;
{ char *test ;
register unsigned char *s , *q ;
cp->type = C_STRING ; /* assume not C_STRNUM */
s = (unsigned char *) string(cp)->str ;
q = s + string(cp)->len ;
while ( scan_code[*s] == SC_SPACE ) s++ ;
if ( s == q ) return ;
while ( scan_code[ q[-1] ] == SC_SPACE ) q-- ;
if ( scan_code[ q[-1] ] != SC_DIGIT &&
q[-1] != '.' ) return ;
switch ( scan_code[*s] )
{
case SC_DIGIT :
case SC_PLUS :
case SC_MINUS :
case SC_DOT :
#if FPE_TRAPS
errno = 0 ;
cp->dval = strtod((char *)s, &test) ;
if ( errno && cp->dval != 0.0 )
rt_error(
"overflow converting %s to double" , s) ;
#else
cp->dval = strtod(s, &test) ;
#endif
if ((char *) q == test ) cp->type = C_STRNUM ;
}
}
/* cast a CELL to a replacement cell */
void cast_to_REPL( cp )
register CELL *cp ;
{ register STRING *sval ;
if ( cp->type < C_STRING ) cast1_to_s(cp) ;
sval = (STRING *) cp->ptr ;
(void) cellcpy(cp, repl_compile(sval)) ;
free_STRING(sval) ;
}
#if NO_STRTOD
static char d_str[] =
"^[ \t]*[-+]?([0-9]+\\.?|\\.[0-9])[0-9]*([eE][-+]?[0-9]+)?" ;
static PTR d_ptr ;
void strtod_init()
{ STRING *sval = new_STRING(d_str) ;
d_ptr = re_compile(sval) ;
free_STRING(sval) ;
}
double strtod( s, endptr)
char *s , **endptr ;
{ double atof() ;
if ( endptr )
{ unsigned len ;
(void) REmatch(s, d_ptr, &len) ;
*endptr = s + len ;
}
return atof(s) ;
}
#endif /* NO_STRTOD */
#if NO_FMOD
double fmod(x, y)
double x, y ;
{ double modf() ;
double ipart ;
return modf(x/y, &ipart) * y ;
}
#endif /* NO_FMOD */
@//E*O*F mawk0.97/cast.c//
chmod u=rw,g=r,o=r mawk0.97/cast.c
echo x - mawk0.97/code.c
sed 's/^@//' > "mawk0.97/code.c" <<'@//E*O*F mawk0.97/code.c//'
/********************************************
code.c
copyright 1991, Michael D. Brennan
This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.
See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/
/* $Log: code.c,v $
* Revision 2.1 91/04/08 08:22:46 brennan
* VERSION 0.97
*
*/
/* code.c */
#include "mawk.h"
#include "code.h"
#include "init.h"
#define CODE_SZ (PAGE_SZ*sizeof(INST))
INST *code_ptr ;
INST *main_start , *main_code_ptr ;
INST *begin_start , *begin_code_ptr ;
INST *end_start , *end_code_ptr ;
unsigned main_size, begin_size, end_size ;
void PROTO(fdump, (void) ) ;
void code_init()
{
main_code_ptr = main_start = (INST *) zmalloc(CODE_SZ) ;
begin_code_ptr = begin_start = (INST *) zmalloc(CODE_SZ) ;
end_code_ptr = end_start = (INST *) zmalloc(CODE_SZ) ;
code_ptr = main_code_ptr ;
}
void code_cleanup()
{
if ( dump_code ) fdump() ; /* dumps all functions */
begin_code_ptr++->op = _HALT ;
if ( (begin_size = begin_code_ptr - begin_start) == 1 ) /* empty */
{
zfree( begin_start, CODE_SZ ) ;
begin_start = (INST *) 0 ;
}
else
if ( begin_size > PAGE_SZ ) overflow("BEGIN code" , PAGE_SZ) ;
else
{ begin_size *= sizeof(INST) ;
begin_start = (INST *) zrealloc(begin_start,CODE_SZ,begin_size) ;
if ( dump_code )
{ fprintf(stderr, "BEGIN\n") ;
da(begin_start, stderr) ;
}
}
end_code_ptr++->op = _HALT ;
if ( (end_size = end_code_ptr - end_start) == 1 ) /* empty */
{
zfree( end_start, CODE_SZ ) ;
end_start = (INST *) 0 ;
}
else
if ( end_size > PAGE_SZ ) overflow("END code" , PAGE_SZ) ;
else
{ end_size *= sizeof(INST) ;
end_start = (INST *) zrealloc(end_start, CODE_SZ, end_size) ;
if ( dump_code )
{ fprintf(stderr, "END\n") ;
da(end_start, stderr) ;
}
}
code_ptr++->op = _HALT ;
if ( (main_size = code_ptr - main_start) == 1 ) /* empty */
{
zfree( main_start, CODE_SZ ) ;
main_start = (INST *) 0 ;
}
else
if ( main_size > PAGE_SZ ) overflow("MAIN code" , PAGE_SZ) ;
else
{ main_size *= sizeof(INST) ;
main_start = (INST *) zrealloc(main_start, CODE_SZ, main_size) ;
if ( dump_code )
{ fprintf(stderr, "MAIN\n") ;
da(main_start, stderr) ;
}
}
}
@//E*O*F mawk0.97/code.c//
chmod u=rw,g=r,o=r mawk0.97/code.c
echo x - mawk0.97/code.h
sed 's/^@//' > "mawk0.97/code.h" <<'@//E*O*F mawk0.97/code.h//'
/********************************************
code.h
copyright 1991, Michael D. Brennan
This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.
See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/
/* $Log: code.h,v $
* Revision 2.1 91/04/08 08:22:48 brennan
* VERSION 0.97
*
*/
/* code.h */
#ifndef CODE_H
#define CODE_H
#include "memory.h"
#include <setjmp.h>
/* coding scope */
#define SCOPE_MAIN 0
#define SCOPE_BEGIN 1
#define SCOPE_END 2
#define SCOPE_FUNCT 3
extern INST *code_ptr ;
extern INST *begin_start , *begin_code_ptr ;
extern INST *end_start , *end_code_ptr ;
extern INST *main_start, *main_code_ptr ;
extern unsigned begin_size, end_size, main_size ;
extern CELL eval_stack[] ;
#define code1(x) code_ptr++ -> op = (x)
#define code2(x,y) (void)( code_ptr++ -> op = (x) ,\
code_ptr++ -> ptr = (PTR)(y) )
/* the machine opcodes */
#define _HALT 0
#define _STOP 1
#define _STOP0 2
#define _PUSHC 3
#define _PUSHINT 4
#define _PUSHA 5
#define _PUSHI 6
#define L_PUSHA 7
#define L_PUSHI 8
#define AE_PUSHA 9
#define AE_PUSHI 10
#define A_PUSHA 11
#define LAE_PUSHA 12
#define LAE_PUSHI 13
#define LA_PUSHA 14
#define F_PUSHA 15
#define FE_PUSHA 16
#define F_PUSHI 17
#define FE_PUSHI 18
#define _POP 19
#define _PULL 20
#define _DUP 21
#define _ADD 22
#define _SUB 23
#define _MUL 24
#define _DIV 25
#define _MOD 26
#define _POW 27
#define _NOT 28
#define _TEST 29
#define A_TEST 30
#define A_DEL 31
#define A_LOOP 32
#define A_CAT 33
#define _UMINUS 34
#define _UPLUS 35
#define _ASSIGN 36
#define _ADD_ASG 37
#define _SUB_ASG 38
#define _MUL_ASG 39
#define _DIV_ASG 40
#define _MOD_ASG 41
#define _POW_ASG 42
#define F_ASSIGN 43
#define F_ADD_ASG 44
#define F_SUB_ASG 45
#define F_MUL_ASG 46
#define F_DIV_ASG 47
#define F_MOD_ASG 48
#define F_POW_ASG 49
#define _CAT 50
#define _BUILTIN 51
#define _PRINT 52
#define _POST_INC 53
#define _POST_DEC 54
#define _PRE_INC 55
#define _PRE_DEC 56
#define F_POST_INC 57
#define F_POST_DEC 58
#define F_PRE_INC 59
#define F_PRE_DEC 60
#define _JMP 61
#define _JNZ 62
#define _JZ 63
#define _EQ 64
#define _NEQ 65
#define _LT 66
#define _LTE 67
#define _GT 68
#define _GTE 69
#define _MATCH 70
#define _EXIT 71
#define _EXIT0 72
#define _NEXT 73
#define _RANGE 74
#define _CALL 75
#define _RET 76
#define _RET0 77
/* next and exit statements */
extern jmp_buf exit_jump, next_jump ;
extern int exit_code ;
#endif /* CODE_H */
@//E*O*F mawk0.97/code.h//
chmod u=rw,g=r,o=r mawk0.97/code.h
echo x - mawk0.97/da.c
sed 's/^@//' > "mawk0.97/da.c" <<'@//E*O*F mawk0.97/da.c//'
/********************************************
da.c
copyright 1991, Michael D. Brennan
This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.
See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/
/* $Log: da.c,v $
* Revision 2.1 91/04/08 08:22:50 brennan
* VERSION 0.97
*
*/
/* da.c */
/* disassemble code */
#include "mawk.h"
#include "code.h"
#include "bi_funct.h"
#include "repl.h"
#include "field.h"
char *PROTO(find_bi_name, (PF_CP) ) ;
void da(start, fp)
INST *start ;
FILE *fp ;
{ CELL *cp ;
register INST *p = start ;
while ( 1 )
{ /* print the relative code address (label) */
fprintf(fp,"%03d ", p - start) ;
switch( p++->op )
{
case _HALT : fprintf(fp,"halt\n") ; return ;
case _STOP : fprintf(fp,"stop\n") ; break ;
case _STOP0 : fprintf(fp, "stop0\n") ; break ;
case _PUSHC :
cp = (CELL *) p++->ptr ;
switch( cp->type )
{ case C_DOUBLE :
fprintf(fp,"pushc\t%.6g\n" , cp ->dval) ;
break ;
case C_STRING :
fprintf(fp,"pushc\t\"%s\"\n" ,
((STRING *)cp->ptr)->str) ;
break ;
case C_RE :
fprintf(fp,"pushc\t0x%x\t/%s/\n" , cp->ptr ,
re_uncompile(cp->ptr) ) ;
break ;
case C_SPACE :
fprintf(fp, "pushc\tspace split\n") ;
break ;
case C_SNULL :
fprintf(fp, "pushc\tnull split\n") ;
break ;
case C_REPL :
fprintf(fp, "pushc\trepl\t%s\n" ,
repl_uncompile(cp) ) ;
break ;
case C_REPLV :
fprintf(fp, "pushc\treplv\t%s\n" ,
repl_uncompile(cp) ) ;
break ;
default :
fprintf(fp,"pushc\tWEIRD\n") ; ;
break ;
}
break ;
case _PUSHA :
fprintf(fp,"pusha\t0x%x\n", p++ -> ptr) ;
break ;
case _PUSHI :
if ( (CELL *)p->ptr == field )
fprintf(fp, "pushi\t$0\n") ;
else fprintf(fp,"pushi\t0x%x\n", p -> ptr) ;
p++ ;
break ;
case L_PUSHA :
fprintf( fp, "l_pusha\t%d\n", p++->op) ;
break ;
case L_PUSHI :
fprintf( fp, "l_pushi\t%d\n", p++->op) ;
break ;
case LAE_PUSHI :
fprintf( fp, "lae_pushi\t%d\n", p++->op) ;
break ;
case LAE_PUSHA :
fprintf( fp, "lae_pusha\t%d\n", p++->op) ;
break ;
case LA_PUSHA :
fprintf( fp, "la_pusha\t%d\n", p++->op) ;
break ;
case F_PUSHA :
fprintf(fp,"f_pusha\t$%d\n" , (CELL *) p++->ptr - field ) ;
break ;
case F_PUSHI :
fprintf(fp,"f_pushi\t$%d\n" , (CELL *) p++->ptr - field ) ;
break ;
case FE_PUSHA :
fprintf(fp,"fe_pusha\n" ) ;
break ;
case FE_PUSHI :
fprintf(fp,"fe_pushi\n" ) ;
break ;
case AE_PUSHA :
fprintf(fp,"ae_pusha\t0x%x\n" , p++->ptr) ;
break ;
case AE_PUSHI :
fprintf(fp,"ae_pushi\t0x%x\n" , p++->ptr) ;
break ;
case A_PUSHA :
fprintf(fp,"a_pusha\t0x%x\n" , p++->ptr) ;
break ;
case A_TEST :
fprintf(fp,"a_test\n" ) ;
break ;
case A_DEL :
fprintf(fp,"a_del\n" ) ;
break ;
case A_CAT :
fprintf(fp,"a_cat\t%d\n", p++->op ) ;
break ;
case _POP :
fprintf(fp,"pop\n") ;
break ;
case _ADD :
fprintf(fp,"add\n") ; break ;
case _SUB :
fprintf(fp,"sub\n") ; break ;
case _MUL :
fprintf(fp,"mul\n") ; break ;
case _DIV :
fprintf(fp,"div\n") ; break ;
case _MOD :
fprintf(fp,"mod\n") ; break ;
case _POW :
fprintf(fp,"pow\n") ; break ;
case _NOT :
fprintf(fp,"not\n") ; break ;
case _UMINUS :
fprintf(fp,"uminus\n") ; break ;
case _UPLUS :
fprintf(fp,"plus\n") ; break ;
case _DUP :
fprintf(fp,"dup\n") ; break ;
case _TEST :
fprintf(fp,"test\n") ; break ;
case _CAT :
fprintf(fp,"cat\n") ; break ;
case _ASSIGN :
fprintf(fp,"assign\n") ; break ;
case _ADD_ASG :
fprintf(fp,"add_asg\n") ; break ;
case _SUB_ASG :
fprintf(fp,"sub_asg\n") ; break ;
case _MUL_ASG :
fprintf(fp,"mul_asg\n") ; break ;
case _DIV_ASG :
fprintf(fp,"div_asg\n") ; break ;
case _MOD_ASG :
fprintf(fp,"mod_asg\n") ; break ;
case _POW_ASG :
fprintf(fp,"pow_asg\n") ; break ;
case F_ASSIGN :
fprintf(fp,"f_assign\n") ; break ;
case F_ADD_ASG :
fprintf(fp,"f_add_asg\n") ; break ;
case F_SUB_ASG :
fprintf(fp,"f_sub_asg\n") ; break ;
case F_MUL_ASG :
fprintf(fp,"f_mul_asg\n") ; break ;
case F_DIV_ASG :
fprintf(fp,"f_div_asg\n") ; break ;
case F_MOD_ASG :
fprintf(fp,"f_mod_asg\n") ; break ;
case F_POW_ASG :
fprintf(fp,"f_pow_asg\n") ; break ;
case _PUSHINT :
fprintf(fp,"pushint\t%d\n" , p++ -> op ) ;
break ;
case _BUILTIN :
fprintf(fp,"%s\n" ,
find_bi_name( (PF_CP) p++ -> ptr ) ) ;
break ;
case _PRINT :
fprintf(fp,"%s\n",
(PF_CP) p++ -> ptr == bi_printf
? "printf" : "print") ;
break ;
case _POST_INC :
fprintf(fp,"post_inc\n") ; break ;
case _POST_DEC :
fprintf(fp,"post_dec\n") ; break ;
case _PRE_INC :
fprintf(fp,"pre_inc\n") ; break ;
case _PRE_DEC :
fprintf(fp,"pre_dec\n") ; break ;
case F_POST_INC :
fprintf(fp,"f_post_inc\n") ; break ;
case F_POST_DEC :
fprintf(fp,"f_post_dec\n") ; break ;
case F_PRE_INC :
fprintf(fp,"f_pre_inc\n") ; break ;
case F_PRE_DEC :
fprintf(fp,"f_pre_dec\n") ; break ;
case _JMP :
case _JNZ :
case _JZ :
{ int j = (p-1)->op ;
char *s = j == _JMP ? "jmp" :
j == _JNZ ? "jnz" : "jz" ;
fprintf(fp,"%s\t\t%03d\n" , s ,
(p - start) + p->op - 1 ) ;
p++ ;
break ;
}
case _EQ :
fprintf(fp,"eq\n") ; break ;
case _NEQ :
fprintf(fp,"neq\n") ; break ;
case _LT :
fprintf(fp,"lt\n") ; break ;
case _LTE :
fprintf(fp,"lte\n") ; break ;
case _GT :
fprintf(fp,"gt\n") ; break ;
case _GTE :
fprintf(fp,"gte\n") ; break ;
case _MATCH :
fprintf(fp,"match_op\n") ; break ;
case A_LOOP :
fprintf(fp,"a_loop\t%03d\n", p-start+p[1].op) ;
p += 2 ;
break ;
case _EXIT :
fprintf(fp, "exit\n") ; break ;
case _EXIT0 :
fprintf(fp, "exit0\n") ; break ;
case _NEXT :
fprintf(fp, "next\n") ; break ;
case _RET :
fprintf(fp, "ret\n") ; break ;
case _RET0 :
fprintf(fp, "ret0\n") ; break ;
case _CALL :
fprintf(fp, "call\t%s\t%d\n",
((FBLOCK*)p->ptr)->name , p[1].op) ;
p += 2 ;
break ;
case _RANGE :
fprintf(fp, "range\t%03d %03d %03d\n",
/* label for pat2, action, follow */
p - start + p[1].op ,
p - start + p[2].op ,
p - start + p[3].op ) ;
p += 4 ;
break ;
default :
fprintf(fp,"bad instruction\n") ;
return ;
}
}
}
static struct {
PF_CP action ;
char *name ;
} special_cases[] = {
bi_length, "length",
bi_split, "split",
bi_match, "match",
bi_getline,"getline",
bi_sub, "sub",
bi_gsub , "gsub",
(PF_CP) 0, (char *) 0 } ;
static char *find_bi_name( p )
PF_CP p ;
{ BI_REC *q ;
int i ;
for( q = bi_funct ; q->name ; q++ )
if ( q->fp == p ) /* found */
return q->name ;
/* next check some special cases */
for( i = 0 ; special_cases[i].action ; i++)
if ( special_cases[i].action == p )
return special_cases[i].name ;
return "unknown builtin" ;
}
static struct fdump {
struct fdump *link ;
FBLOCK *fbp ;
} *fdump_list ; /* linked list of all user functions */
void add_to_fdump_list( fbp )
FBLOCK *fbp ;
{ struct fdump *p = (struct fdump *)zmalloc(sizeof(struct fdump)) ;
p->fbp = fbp ;
p->link = fdump_list ; fdump_list = p ;
}
void fdump()
{
register struct fdump *p, *q = fdump_list ;
while ( p = q )
{ q = p->link ;
fprintf(stderr, "function %s\n" , p->fbp->name) ;
da(p->fbp->code, stderr) ;
zfree(p, sizeof(struct fdump)) ;
}
}
@//E*O*F mawk0.97/da.c//
chmod u=rw,g=r,o=r mawk0.97/da.c
echo x - mawk0.97/error.c
sed 's/^@//' > "mawk0.97/error.c" <<'@//E*O*F mawk0.97/error.c//'
/********************************************
error.c
copyright 1991, Michael D. Brennan
This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.
See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/
/* $Log: error.c,v $
* Revision 2.2 91/04/09 12:38:52 brennan
* added static to funct decls to satisfy STARDENT compiler
*
* Revision 2.1 91/04/08 08:22:52 brennan
* VERSION 0.97
*
*/
#include "mawk.h"
#include "scan.h"
#include "bi_vars.h"
#ifndef EOF
#define EOF (-1)
#endif
/* statics */
static void PROTO( check_FILENAME, (void) ) ;
static void PROTO( unexpected_char, (void) ) ;
static void PROTO( missing, (int, char *, int) ) ;
static char *PROTO( type_to_str, (int) ) ;
static struct token_str {
short token ;
char *str ; } token_str[] = {
EOF , "end of file" ,
NL , "end of line",
SEMI_COLON , ";" ,
LBRACE , "{" ,
RBRACE , "}" ,
SC_FAKE_SEMI_COLON, "}",
LPAREN , "(" ,
RPAREN , ")" ,
LBOX , "[",
RBOX , "]",
QMARK , "?",
COLON , ":",
OR, "||",
AND, "&&",
P_OR, "||",
P_AND, "&&",
ASSIGN , "=" ,
ADD_ASG, "+=",
SUB_ASG, "-=",
MUL_ASG, "*=",
DIV_ASG, "/=",
MOD_ASG, "%=",
POW_ASG, "^=",
EQ , "==" ,
NEQ , "!=",
LT, "<" ,
LTE, "<=" ,
GT, ">",
GTE, ">=" ,
MATCH, "~",
NOT_MATCH, "!~",
PLUS , "+" ,
MINUS, "-" ,
MUL , "*" ,
DIV, "/" ,
MOD, "%" ,
POW, "^" ,
INC , "++" ,
DEC , "--" ,
NOT, "!" ,
COMMA, "," ,
CONSTANT , temp_buff.string_buff ,
ID , temp_buff.string_buff ,
FUNCT_ID , temp_buff.string_buff ,
BUILTIN , temp_buff.string_buff ,
IO_OUT, temp_buff.string_buff,
IO_IN, "<" ,
PIPE, "|" ,
DOLLAR, "$" ,
FIELD, "$" ,
0, (char *) 0 } ;
/* if paren_cnt >0 and we see one of these, we are missing a ')' */
static int missing_rparen[] =
{ EOF, NL, SEMI_COLON, SC_FAKE_SEMI_COLON, RBRACE, 0 } ;
/* ditto for '}' */
static int missing_rbrace[] =
{ EOF, BEGIN, END , 0 } ;
static void missing( c, n , ln)
int c ;
char *n ;
int ln ;
{ errmsg(0, "line %u: missing %c near %s" , ln, c, n) ; }
void yyerror(s)
char *s ; /* we won't use s as input
(yacc and bison force this).
We will use s for storage to keep lint or the compiler
off our back */
{ struct token_str *p ;
int *ip ;
s = (char *) 0 ;
for ( p = token_str ; p->token ; p++ )
if ( current_token == p->token )
{ s = p->str ; break ; }
if ( ! s ) /* search the keywords */
s = find_kw_str(current_token) ;
if ( s )
{
if ( paren_cnt )
for( ip = missing_rparen ; *ip ; ip++)
if ( *ip == current_token )
{ missing(')', s, token_lineno) ;
paren_cnt = 0 ;
goto done ;
}
if ( brace_cnt )
for( ip = missing_rbrace ; *ip ; ip++)
if ( *ip == current_token )
{ missing('}', s, token_lineno) ;
brace_cnt = 0 ;
goto done ;
}
compile_error("syntax error at or near %s", s) ;
}
else /* special cases */
switch ( current_token )
{
case UNEXPECTED :
unexpected_char() ;
goto done ;
case BAD_DECIMAL :
compile_error(
"syntax error in decimal constant %s",
temp_buff.string_buff ) ;
break ;
case RE :
compile_error(
"syntax error at or near /%s/",
temp_buff.string_buff ) ;
break ;
default :
compile_error("syntax error") ;
break ;
}
return ;
done :
if ( ++compile_error_count == MAX_COMPILE_ERRORS ) mawk_exit(1) ;
}
/* system provided errnos and messages */
extern int sys_nerr ;
extern char *sys_errlist[] ;
#ifdef __STDC__
#include <stdarg.h>
/* generic error message with a hook into the system error
messages if errnum > 0 */
void errmsg(int errnum, char *format, ...)
{ va_list args ;
fprintf(stderr, "%s: " , progname) ;
va_start(args, format) ;
(void) vfprintf(stderr, format, args) ;
va_end(args) ;
if ( errnum > 0 && errnum < sys_nerr )
fprintf(stderr, " (%s)" , sys_errlist[errnum]) ;
fprintf( stderr, "\n") ;
}
void compile_error(char *format, ...)
{ va_list args ;
fprintf(stderr, "%s: line %u: " , progname, token_lineno) ;
va_start(args, format) ;
vfprintf(stderr, format, args) ;
va_end(args) ;
fprintf(stderr, "\n") ;
if ( ++compile_error_count == MAX_COMPILE_ERRORS ) mawk_exit(1) ;
}
void rt_error( char *format, ...)
{ va_list args ;
fprintf(stderr, "%s: run time error: " , progname ) ;
va_start(args, format) ;
vfprintf(stderr, format, args) ;
va_end(args) ;
check_FILENAME() ;
fprintf(stderr, "\n\t(FILENAME=\"%s\" FNR=%g NR=%g)\n" ,
string(bi_vars+FILENAME)->str, bi_vars[FNR].dval,
bi_vars[NR].dval) ;
mawk_exit(1) ;
}
#else
#include <varargs.h>
/* void errmsg(errnum, format, ...) */
void errmsg( va_alist)
va_dcl
{ va_list ap ;
int errnum ;
char *format ;
fprintf(stderr, "%s: " , progname) ;
va_start(ap) ;
errnum = va_arg(ap, int) ;
format = va_arg(ap, char *) ;
(void) vfprintf(stderr, format, ap) ;
if ( errnum > 0 && errnum < sys_nerr )
fprintf(stderr, " (%s)" , sys_errlist[errnum]) ;
fprintf( stderr, "\n") ;
}
void compile_error( va_alist )
va_dcl
{ va_list args ;
char *format ;
fprintf(stderr, "%s: line %u: " , progname, token_lineno) ;
va_start(args) ;
format = va_arg(args, char *) ;
vfprintf(stderr, format, args) ;
va_end(args) ;
fprintf(stderr, "\n") ;
if ( ++compile_error_count == MAX_COMPILE_ERRORS ) mawk_exit(1) ;
}
void rt_error( va_alist )
va_dcl
{ va_list args ;
char *format ;
fprintf(stderr, "%s: run time error: " , progname ) ;
va_start(args) ;
format = va_arg(args, char *) ;
vfprintf(stderr, format, args) ;
va_end(args) ;
check_FILENAME() ;
fprintf(stderr, "\n\tFILENAME=\"%s\" FNR=%g NR=%g\n" ,
string(bi_vars+FILENAME)->str, bi_vars[FNR].dval,
bi_vars[NR].dval) ;
mawk_exit(1) ;
}
#endif
void bozo(s)
char *s ;
{ errmsg(0, "bozo: %s" , s) ; mawk_exit(1) ; }
void overflow(s, size)
char *s ; unsigned size ;
{ errmsg(0 , "program limit exceeded: %s size=%u", s, size) ;
mawk_exit(1) ; }
static void check_FILENAME()
{
if ( bi_vars[FILENAME].type != C_STRING )
cast1_to_s(bi_vars + FILENAME) ;
if ( bi_vars[FNR].type != C_DOUBLE )
cast1_to_d(bi_vars + FNR ) ;
if ( bi_vars[NR].type != C_DOUBLE )
cast1_to_d(bi_vars + NR ) ;
}
/* run time */
void rt_overflow(s, size)
char *s ; unsigned size ;
{ check_FILENAME() ;
errmsg(0 ,
"program limit exceeded: %s size=%u\n\
\t(FILENAME=\"%s\" FNR=%g NR=%g)",
s, size, string(bi_vars+FILENAME)->str,
bi_vars[FNR].dval,
bi_vars[NR].dval) ;
mawk_exit(1) ;
}
static void unexpected_char()
{ int c = yylval.ival ;
fprintf(stderr, "%s: %u: ", progname, token_lineno) ;
if ( c > ' ')
fprintf(stderr, "unexpected character '%c'\n" , c) ;
else
fprintf(stderr, "unexpected character 0x%02x\n" , c) ;
}
static char *type_to_str( type )
int type ;
{ char *retval ;
switch( type )
{
case ST_VAR : retval = "variable" ; break ;
case ST_ARRAY : retval = "array" ; break ;
case ST_FUNCT : retval = "function" ; break ;
case ST_LOCAL_VAR : retval = "local variable" ; break ;
case ST_LOCAL_ARRAY : retval = "local array" ; break ;
default : bozo("type_to_str") ;
}
return retval ;
}
/* emit an error message about a type clash */
void type_error(p)
SYMTAB *p ;
{ compile_error("illegal reference to %s %s",
type_to_str(p->type) , p->name) ;
}
@//E*O*F mawk0.97/error.c//
chmod u=rw,g=r,o=r mawk0.97/error.c
echo x - mawk0.97/execute.c
sed 's/^@//' > "mawk0.97/execute.c" <<'@//E*O*F mawk0.97/execute.c//'
/********************************************
execute.c
copyright 1991, Michael D. Brennan
This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.
See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/
/* $Log: execute.c,v $
* Revision 2.2 91/04/09 12:38:54 brennan
* added static to funct decls to satisfy STARDENT compiler
*
* Revision 2.1 91/04/08 08:22:55 brennan
* VERSION 0.97
*
*/
#include "mawk.h"
#include "code.h"
#include "memory.h"
#include "symtype.h"
#include "field.h"
#include "bi_funct.h"
#include "regexp.h"
#include "repl.h"
#include <math.h>
/* static functions */
static int PROTO( compare, (CELL *) ) ;
static void PROTO( eval_overflow, (void) ) ;
#ifdef DEBUG
#define inc_sp() if( ++sp == eval_stack+EVAL_STACK_SIZE )\
eval_overflow()
#else
/* If things are working, the only reason the eval stack should
overflow is too much function recursion
(checked for at _CALL below */
#define inc_sp() sp++
#endif
#define SAFETY 3 /* if we get within 3 of stack top emit
overflow */
/* The stack machine that executes the code */
CELL eval_stack[EVAL_STACK_SIZE] ;
static void eval_overflow()
{ overflow("eval stack" , EVAL_STACK_SIZE) ; mawk_exit(1) ; }
/* if this flag is on, recursive calls to execute need to
return to the _CALL statement. This only happens
inside array loops */
int returning ;
INST *execute(cdp, sp, fp)
register INST *cdp ; /* code ptr, start execution here */
register CELL *sp ; /* eval_stack pointer */
CELL *fp ; /* frame ptr into eval_stack for
user defined functions */
{
/* some useful temporaries */
CELL *cp , tc ;
int t ;
#ifdef DEBUG
CELL *entry_sp = sp ;
#endif
while ( 1 )
switch( cdp++ -> op )
{ case _HALT :
case _STOP :
#ifdef DEBUG
/* check the stack is sane */
if ( sp != entry_sp ) bozo("stop") ;
return cdp - 1 ;
case _STOP0 : /* if debugging stops range patterns */
if ( sp != entry_sp+1 ) bozo("stop0") ;
#else
case _STOP0 :
#endif
return cdp - 1 ;
case _PUSHC :
inc_sp() ;
(void) cellcpy(sp, cdp++ -> ptr) ;
break ;
case F_PUSHA :
if ( (CELL*)cdp->ptr != field && nf < 0 ) split_field0() ;
/* fall thru */
case _PUSHA :
case A_PUSHA :
inc_sp() ;
sp -> ptr = cdp++ -> ptr ;
break ;
case _PUSHI : /* put contents of next address on stack*/
inc_sp() ;
(void) cellcpy(sp, cdp++ -> ptr) ;
break ;
case L_PUSHI :
/* put the contents of a local var on stack,
cdp->op holds the offset from the frame pointer */
inc_sp() ;
(void) cellcpy(sp, fp + cdp++->op) ;
break ;
case L_PUSHA : /* put a local address on eval stack */
inc_sp() ;
sp->ptr = (PTR)(fp + cdp++->op) ;
break ;
case F_PUSHI :
/* note $0 , RS , FS and OFMT are loaded by _PUSHI */
inc_sp() ;
if ( nf < 0 ) split_field0() ;
if ( (t = (CELL *) cdp->ptr - field) <= nf ||
t == NF )
{ (void) cellcpy(sp, cdp++ -> ptr) ; }
else /* an unset field */
{ sp->type = C_STRING ;
sp->ptr = (PTR) & null_str ;
null_str.ref_cnt++ ;
cdp++ ;
}
break ;
case FE_PUSHA :
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
if ( (t = (int) sp->dval) < 0 )
rt_error( "negative field index(%d)", t) ;
if ( t > MAX_FIELD )
rt_overflow("MAX_FIELD", MAX_FIELD) ;
if ( t && nf < 0 ) split_field0() ;
sp->ptr = (PTR) &field[t] ;
break ;
case FE_PUSHI :
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
if ( (t = (int) sp->dval) == 0 )
{ (void) cellcpy(sp, &field[0]) ; break ; }
if ( t < 0 )
rt_error( "negative field index(%d)", t) ;
if ( t > MAX_FIELD )
rt_overflow("MAX_FIELD", MAX_FIELD) ;
if ( nf < 0) split_field0() ;
if ( t <= nf ) (void) cellcpy(sp, &field[t]) ;
else
{ sp->type = C_STRING ;
sp->ptr = (PTR) & null_str ;
null_str.ref_cnt++ ;
}
break ;
case AE_PUSHA :
/* top of stack has an expr, cdp->ptr points at an
array, replace the expr with the cell address inside
the array */
cast1_to_s(sp) ;
cp = array_find((ARRAY)cdp++->ptr, sp->ptr, 0) ;
free_STRING( string(sp) );
sp->ptr = (PTR) cp ;
break ;
case AE_PUSHI :
/* top of stack has an expr, cdp->ptr points at an
array, replace the expr with the contents of the
cell inside the array */
cast1_to_s(sp) ;
cp = array_find((ARRAY) cdp++->ptr, sp->ptr, 0) ;
free_STRING(string(sp)) ;
(void) cellcpy(sp, cp) ;
break ;
case LAE_PUSHI :
/* sp[0] is an expression
cdp->op is offset from frame pointer of a CELL which
has an ARRAY in the ptr field, replace expr
with array[expr]
*/
cast1_to_s(sp) ;
cp = array_find( (ARRAY)fp[cdp++->op].ptr, sp->ptr, 0) ;
free_STRING(string(sp)) ;
(void) cellcpy(sp, cp) ;
break ;
case LAE_PUSHA :
/* sp[0] is an expression
cdp->op is offset from frame pointer of a CELL which
has an ARRAY in the ptr field, replace expr
with & array[expr]
*/
cast1_to_s(sp) ;
cp = array_find( (ARRAY)fp[cdp++->op].ptr, sp->ptr, 0) ;
free_STRING(string(sp)) ;
sp->ptr = (PTR) cp ;
break ;
case LA_PUSHA :
/* cdp->op is offset from frame pointer of a CELL which
has an ARRAY in the ptr field. Push this ARRAY
on the eval stack
*/
inc_sp() ;
sp->ptr = fp[cdp++->op].ptr ;
break ;
case A_LOOP :
cdp = array_loop(cdp,sp,fp) ;
if ( returning ) return cdp ; /*value doesn't matter*/
sp -= 2 ;
break ;
case _POP :
cell_destroy(sp) ;
sp-- ;
break ;
case _DUP :
(void) cellcpy(sp+1, sp) ;
sp++ ; break ;
case _ASSIGN :
/* top of stack has an expr, next down is an
address, put the expression in *address and
replace the address with the expression */
/* don't propagate type C_MBSTRN */
if ( sp->type == C_MBSTRN ) check_strnum(sp) ;
sp-- ;
cell_destroy( ((CELL *)sp->ptr) ) ;
(void) cellcpy( sp, cellcpy(sp->ptr, sp+1) ) ;
cell_destroy(sp+1) ;
break ;
case F_ASSIGN : /* assign to a field */
if (sp->type == C_MBSTRN) check_strnum(sp) ;
sp-- ;
field_assign((CELL*)sp->ptr - field, sp+1) ;
cell_destroy(sp+1) ;
(void) cellcpy(sp, (CELL *) sp->ptr) ;
break ;
case _ADD_ASG:
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
cp->dval += sp-- -> dval ;
sp->type = C_DOUBLE ;
sp->dval = cp->dval ;
break ;
case _SUB_ASG:
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
cp->dval -= sp-- -> dval ;
sp->type = C_DOUBLE ;
sp->dval = cp->dval ;
break ;
case _MUL_ASG:
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
cp->dval *= sp-- -> dval ;
sp->type = C_DOUBLE ;
sp->dval = cp->dval ;
break ;
case _DIV_ASG:
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
cp->dval /= sp-- -> dval ;
sp->type = C_DOUBLE ;
sp->dval = cp->dval ;
break ;
case _MOD_ASG:
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
cp->dval = fmod(cp->dval,sp-- -> dval) ;
sp->type = C_DOUBLE ;
sp->dval = cp->dval ;
break ;
case _POW_ASG:
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
cp->dval = pow(cp->dval,sp-- -> dval) ;
sp->type = C_DOUBLE ;
sp->dval = cp->dval ;
break ;
/* will anyone ever use these ? */
case F_ADD_ASG :
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
cast1_to_d( cellcpy(&tc, cp) ) ;
tc.dval += sp-- -> dval ;
sp->type = C_DOUBLE ;
sp->dval = tc.dval ;
field_assign(cp-field, &tc) ;
break ;
case F_SUB_ASG :
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
cast1_to_d( cellcpy(&tc, cp) ) ;
tc.dval -= sp-- -> dval ;
sp->type = C_DOUBLE ;
sp->dval = tc.dval ;
field_assign(cp-field, &tc) ;
break ;
case F_MUL_ASG :
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
cast1_to_d( cellcpy(&tc, cp) ) ;
tc.dval *= sp-- -> dval ;
sp->type = C_DOUBLE ;
sp->dval = tc.dval ;
field_assign(cp-field, &tc) ;
break ;
case F_DIV_ASG :
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
cast1_to_d( cellcpy(&tc, cp) ) ;
tc.dval /= sp-- -> dval ;
sp->type = C_DOUBLE ;
sp->dval = tc.dval ;
field_assign(cp-field, &tc) ;
break ;
case F_MOD_ASG :
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
cast1_to_d( cellcpy(&tc, cp) ) ;
tc.dval = fmod(tc.dval, sp-- -> dval) ;
sp->type = C_DOUBLE ;
sp->dval = tc.dval ;
field_assign(cp-field, &tc) ;
break ;
case F_POW_ASG :
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
cp = (CELL *) (sp-1)->ptr ;
cast1_to_d( cellcpy(&tc, cp) ) ;
tc.dval = pow(tc.dval, sp-- -> dval) ;
sp->type = C_DOUBLE ;
sp->dval = tc.dval ;
field_assign(cp-field, &tc) ;
break ;
case _ADD :
sp-- ;
if ( TEST2(sp) != TWO_DOUBLES )
cast2_to_d(sp) ;
sp[0].dval += sp[1].dval ;
break ;
case _SUB :
sp-- ;
if ( TEST2(sp) != TWO_DOUBLES )
cast2_to_d(sp) ;
sp[0].dval -= sp[1].dval ;
break ;
case _MUL :
sp-- ;
if ( TEST2(sp) != TWO_DOUBLES )
cast2_to_d(sp) ;
sp[0].dval *= sp[1].dval ;
break ;
case _DIV :
sp-- ;
if ( TEST2(sp) != TWO_DOUBLES )
cast2_to_d(sp) ;
sp[0].dval /= sp[1].dval ;
break ;
case _MOD :
sp-- ;
if ( TEST2(sp) != TWO_DOUBLES )
cast2_to_d(sp) ;
sp[0].dval = fmod(sp[0].dval,sp[1].dval) ;
break ;
case _POW :
sp-- ;
if ( TEST2(sp) != TWO_DOUBLES )
cast2_to_d(sp) ;
sp[0].dval = pow(sp[0].dval,sp[1].dval) ;
break ;
case _NOT :
reswitch_1:
switch( sp->type )
{ case C_NOINIT :
sp->dval = 1.0 ; break ;
case C_DOUBLE :
sp->dval = sp->dval ? 0.0 : 1.0 ;
break ;
case C_STRING :
sp->dval = string(sp)->len ? 0.0 : 1.0 ;
free_STRING(string(sp)) ;
break ;
case C_STRNUM : /* test as a number */
sp->dval = sp->dval ? 0.0 : 1.0 ;
free_STRING(string(sp)) ;
break ;
case C_MBSTRN :
check_strnum(sp) ;
goto reswitch_1 ;
default :
bozo("bad type on eval stack") ;
}
sp->type = C_DOUBLE ;
break ;
case _TEST :
reswitch_2:
switch( sp->type )
{ case C_NOINIT :
sp->dval = 0.0 ; break ;
case C_DOUBLE :
sp->dval = sp->dval ? 1.0 : 0.0 ;
break ;
case C_STRING :
sp->dval = string(sp)->len ? 1.0 : 0.0 ;
free_STRING(string(sp)) ;
break ;
case C_STRNUM : /* test as a number */
sp->dval = sp->dval ? 0.0 : 1.0 ;
free_STRING(string(sp)) ;
break ;
case C_MBSTRN :
check_strnum(sp) ;
goto reswitch_2 ;
default :
bozo("bad type on eval stack") ;
}
sp->type = C_DOUBLE ;
break ;
case _UMINUS :
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
sp->dval = - sp->dval ;
break ;
case _UPLUS :
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
break ;
case _CAT :
{ unsigned len1, len2 ;
char *str1, *str2 ;
STRING *b ;
sp-- ;
if ( TEST2(sp) != TWO_STRINGS )
cast2_to_s(sp) ;
str1 = string(sp)->str ;
len1 = string(sp)->len ;
str2 = string(sp+1)->str ;
len2 = string(sp+1)->len ;
b = new_STRING((char *)0, len1+len2) ;
(void) memcpy(b->str, str1, len1) ;
(void) memcpy(b->str + len1, str2, len2) ;
free_STRING(string(sp)) ;
free_STRING( string(sp+1) ) ;
sp->ptr = (PTR) b ;
break ;
}
case _PUSHINT :
inc_sp() ;
sp->type = cdp++ -> op ;
break ;
case _BUILTIN :
case _PRINT :
sp = (* (PF_CP) cdp++ -> ptr) (sp) ;
break ;
case _POST_INC :
(void) cellcpy(sp, cp = (CELL *)sp->ptr) ;
if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
cp->dval += 1.0 ;
break ;
case _POST_DEC :
(void) cellcpy(sp, cp = (CELL *)sp->ptr) ;
if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
cp->dval -= 1.0 ;
break ;
case _PRE_INC :
cp = (CELL *) sp->ptr ;
if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
sp->dval = cp->dval += 1.0 ;
sp->type = C_DOUBLE ;
break ;
case _PRE_DEC :
cp = (CELL *) sp->ptr ;
if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
sp->dval = cp->dval -= 1.0 ;
sp->type = C_DOUBLE ;
break ;
case F_POST_INC :
cp = (CELL *) sp->ptr ;
(void) cellcpy(sp, cellcpy(&tc, cp) ) ;
cast1_to_d(&tc) ;
tc.dval += 1.0 ;
field_assign(cp-field, &tc) ;
break ;
case F_POST_DEC :
cp = (CELL *) sp->ptr ;
(void) cellcpy(sp, cellcpy(&tc, cp) ) ;
cast1_to_d(&tc) ;
tc.dval -= 1.0 ;
field_assign(cp-field, &tc) ;
break ;
case F_PRE_INC :
cp = (CELL *) sp->ptr ;
cast1_to_d(cellcpy(&tc, cp)) ;
sp->dval = tc.dval += 1.0 ;
sp->type = C_DOUBLE ;
field_assign(cp-field, sp) ;
break ;
case F_PRE_DEC :
cp = (CELL *) sp->ptr ;
cast1_to_d(cellcpy(&tc, cp)) ;
sp->dval = tc.dval -= 1.0 ;
sp->type = C_DOUBLE ;
field_assign(cp-field, sp) ;
break ;
case _JMP :
cdp += cdp->op - 1 ;
break ;
case _JNZ :
/* jmp if top of stack is non-zero and pop stack */
if ( test( sp ) )
cdp += cdp->op - 1 ;
else cdp++ ;
cell_destroy(sp) ;
sp-- ;
break ;
case _JZ :
/* jmp if top of stack is zero and pop stack */
if ( ! test( sp ) )
cdp += cdp->op - 1 ;
else cdp++ ;
cell_destroy(sp) ;
sp-- ;
break ;
/* the relation operations */
/* compare() makes sure string ref counts are OK */
case _EQ :
t = compare(--sp) ;
sp->type = C_DOUBLE ;
sp->dval = t == 0 ? 1.0 : 0.0 ;
break ;
case _NEQ :
t = compare(--sp) ;
sp->type = C_DOUBLE ;
sp->dval = t ? 1.0 : 0.0 ;
break ;
case _LT :
t = compare(--sp) ;
sp->type = C_DOUBLE ;
sp->dval = t < 0 ? 1.0 : 0.0 ;
break ;
case _LTE :
t = compare(--sp) ;
sp->type = C_DOUBLE ;
sp->dval = t <= 0 ? 1.0 : 0.0 ;
break ;
case _GT :
t = compare(--sp) ;
sp->type = C_DOUBLE ;
sp->dval = t > 0 ? 1.0 : 0.0 ;
break ;
case _GTE :
t = compare(--sp) ;
sp->type = C_DOUBLE ;
sp->dval = t >= 0 ? 1.0 : 0.0 ;
break ;
case _MATCH :
/* does sp[-1] match sp[0] as re */
if ( sp->type != C_RE ) cast_to_RE(sp) ;
if ( (--sp)->type < C_STRING ) cast1_to_s(sp) ;
t = REtest(string(sp)->str, (sp+1)->ptr) ;
free_STRING(string(sp)) ;
sp->type = C_DOUBLE ;
sp->dval = t ? 1.0 : 0.0 ;
break ;
case A_TEST :
/* entry : sp[0].ptr-> an array
sp[-1] is an expression
we compute expression in array */
if ( (--sp)->type < C_STRING ) cast1_to_s(sp) ;
t = array_test( (sp+1)->ptr, string(sp)) ;
free_STRING(string(sp)) ;
sp->type = C_DOUBLE ;
sp->dval = t ? 1.0 : 0.0 ;
break ;
case A_DEL :
/* sp[0].ptr -> array)
sp[-1] is an expr
delete array[expr] */
cast1_to_s(--sp) ;
array_delete( sp[1].ptr , sp->ptr) ;
free_STRING( string(sp) ) ;
sp-- ;
break ;
/* form a multiple array index */
case A_CAT :
sp = array_cat(sp, cdp++->op) ;
break ;
case _EXIT0 :
longjmp( exit_jump, 1) ;
case _EXIT :
if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
exit_code = (int) sp->dval ;
longjmp( exit_jump, 1) ;
case _NEXT :
longjmp(next_jump, 1) ;
case _RANGE :
/* test a range pattern: pat1, pat2 { action }
entry :
cdp[0].op -- a flag, test pat1 if on else pat2
cdp[1].op -- offset of pat2 code from cdp
cdp[2].op -- offset of action code from cdp
cdp[3].op -- offset of code after the action from cdp
cdp[4] -- start of pat1 code
*/
#define FLAG cdp[0].op
#define PAT2 cdp[1].op
#define ACTION cdp[2].op
#define FOLLOW cdp[3].op
#define PAT1 4
if ( FLAG ) /* test again pat1 */
{
(void) execute(cdp + PAT1,sp, fp) ;
t = test(sp+1) ;
cell_destroy(sp+1) ;
if ( t ) FLAG = 0 ;
else
{ cdp += FOLLOW ;
break ; /* break the switch */
}
}
/* test against pat2 and then perform the action */
(void) execute(cdp + PAT2, sp, fp) ;
FLAG = test(sp+1) ;
cell_destroy(sp+1) ;
cdp += ACTION ;
break ;
/* function calls */
case _RET0 :
inc_sp() ;
sp->type = C_NOINIT ;
/* fall thru */
case _RET :
#ifdef DEBUG
if ( sp != entry_sp+1 ) bozo("ret") ;
#endif
returning = 1 ;
return cdp-1 ;
case _CALL :
{ FBLOCK *fbp = (FBLOCK*) cdp++->ptr ;
int a_args = cdp++->op ; /* actual number of args */
CELL *nfp = sp - a_args + 1 ; /* new fp for callee */
CELL *local_p = sp+1; /* first local argument on stack */
char *type_p ; /* pts to type of an argument */
if ( fbp->nargs ) type_p = fbp->typev + a_args ;
/* create space for locals */
if ( t = fbp->nargs - a_args ) /* have local args */
{
if ( sp + t >= eval_stack + EVAL_STACK_SIZE - SAFETY )
eval_overflow() ;
while ( t-- )
{ (++sp)->type = C_NOINIT ;
if ( *type_p++ == ST_LOCAL_ARRAY )
sp->ptr = (PTR) new_ARRAY() ;
}
}
type_p-- ; /* *type_p is type of last arg */
(void) execute(fbp->code, sp, nfp) ;
#ifdef DEBUG
if ( !returning ) bozo("call") ;
#endif
returning = 0 ;
/* cleanup the callee's arguments */
if ( sp >= nfp )
{
cp = sp+1 ; /* cp -> the function return */
do
{
if ( *type_p-- == ST_LOCAL_ARRAY )
{ if ( sp >= local_p ) array_free(sp->ptr) ; }
else cell_destroy(sp) ;
} while ( --sp >= nfp ) ;
(void) cellcpy(++sp, cp) ;
cell_destroy(cp) ;
}
else sp++ ; /* no arguments passed */
}
break ;
default :
bozo("bad opcode") ;
}
}
int test( cp ) /* test if a cell is null or not */
register CELL *cp ;
{
reswitch :
switch ( cp->type )
{
case C_NOINIT : return 0 ;
case C_STRNUM : /* test as a number */
case C_DOUBLE : return cp->dval != 0.0 ;
case C_STRING : return string(cp)->len ;
case C_MBSTRN : check_strnum(cp) ; goto reswitch ;
default :
bozo("bad cell type in call to test") ;
}
}
/* compare cells at cp and cp+1 and
frees STRINGs at those cells
*/
static int compare(cp)
register CELL *cp ;
{ int k ;
reswitch :
switch( TEST2(cp) )
{ case TWO_NOINITS : return 0 ;
case TWO_DOUBLES :
two_d:
return cp->dval > (cp+1)->dval ? 1 :
cp->dval < (cp+1)->dval ? -1 : 0 ;
case TWO_STRINGS :
case STRING_AND_STRNUM :
two_s:
k = strcmp(string(cp)->str, string(cp+1)->str) ;
free_STRING( string(cp) ) ;
free_STRING( string(cp+1) ) ;
return k ;
case NOINIT_AND_DOUBLE :
case NOINIT_AND_STRNUM :
case DOUBLE_AND_STRNUM :
case TWO_STRNUMS :
cast2_to_d(cp) ; goto two_d ;
case NOINIT_AND_STRING :
case DOUBLE_AND_STRING :
cast2_to_s(cp) ; goto two_s ;
case TWO_MBSTRNS :
check_strnum(cp) ; check_strnum(cp+1) ;
goto reswitch ;
case NOINIT_AND_MBSTRN :
case DOUBLE_AND_MBSTRN :
case STRING_AND_MBSTRN :
case STRNUM_AND_MBSTRN :
check_strnum( cp->type == C_MBSTRN ? cp : cp+1 ) ;
goto reswitch ;
default : /* there are no default cases */
bozo("bad cell type passed to compare") ;
}
}
/* does not assume target was a cell, if so
then caller should have made a previous
call to cell_destroy */
CELL *cellcpy(target, source)
register CELL *target, *source ;
{ switch( target->type = source->type )
{ case C_NOINIT :
case C_SPACE :
case C_SNULL :
break ;
case C_DOUBLE :
target->dval = source->dval ;
break ;
case C_STRNUM :
target->dval = source->dval ;
/* fall thru */
case C_REPL :
case C_MBSTRN :
case C_STRING :
string(source)->ref_cnt++ ;
/* fall thru */
case C_RE :
target->ptr = source->ptr ;
break ;
case C_REPLV :
(void) replv_cpy(target, source) ;
break ;
default :
bozo("bad cell passed to cellcpy()") ;
break ;
}
return target ;
}
#ifdef DEBUG
void DB_cell_destroy(cp) /* HANGOVER time */
register CELL *cp ;
{
switch( cp->type )
{ case C_NOINIT :
case C_DOUBLE : break ;
case C_MBSTRN :
case C_STRING :
case C_STRNUM :
if ( -- string(cp)->ref_cnt == 0 )
zfree(string(cp) , string(cp)->len+5) ;
break ;
case C_RE :
bozo("cell destroy called on RE cell") ;
default :
bozo("cell destroy called on bad cell type") ;
}
}
#endif
@//E*O*F mawk0.97/execute.c//
chmod u=rw,g=r,o=r mawk0.97/execute.c
echo x - mawk0.97/fcall.c
sed 's/^@//' > "mawk0.97/fcall.c" <<'@//E*O*F mawk0.97/fcall.c//'
/********************************************
fcall.c
copyright 1991, Michael D. Brennan
This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.
See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/
/*$Log: fcall.c,v $
* Revision 2.1 91/04/08 08:22:59 brennan
* VERSION 0.97
*
*/
#include "mawk.h"
#include "symtype.h"
#include "code.h"
/* This file has functions involved with type checking of
function calls
*/
static FCALL_REC *PROTO(first_pass, (FCALL_REC *) ) ;
static CA_REC *PROTO(call_arg_check, (FBLOCK *, CA_REC *,
INST *, unsigned) ) ;
static int PROTO(arg_cnt_ok, (FBLOCK *,CA_REC *, unsigned) ) ;
static int check_progress ;
/* flag that indicates call_arg_check() was able to type
check some call arguments */
/* type checks a list of call arguments,
returns a list of arguments whose type is still unknown
*/
static CA_REC *call_arg_check( callee, entry_list , start, line_no)
FBLOCK *callee ;
CA_REC *entry_list ;
INST *start ; /* to locate patch */
unsigned line_no ; /* for error messages */
{ register CA_REC *q ;
CA_REC *exit_list = (CA_REC *) 0 ;
check_progress = 0 ;
/* loop :
take q off entry_list
test it
if OK zfree(q) else put on exit_list
*/
while ( q = entry_list )
{
entry_list = q->link ;
if ( q->type == ST_NONE )
{ /* try to infer the type */
/* it might now be in symbol table */
if ( q->sym_p->type == ST_VAR )
{ /* set type and patch */
q->type = CA_EXPR ;
start[q->call_offset+1].ptr = (PTR) q->sym_p->stval.cp ;
}
else
if ( q->sym_p->type == ST_ARRAY )
{ q->type = CA_ARRAY ;
start[q->call_offset].op = A_PUSHA ;
start[q->call_offset+1].ptr = (PTR) q->sym_p->stval.array ;
}
else /* try to infer from callee */
{
switch( callee->typev[q->arg_num] )
{
case ST_LOCAL_VAR :
q->type = CA_EXPR ;
q->sym_p->type = ST_VAR ;
q->sym_p->stval.cp = new_CELL() ;
q->sym_p->stval.cp->type = C_NOINIT ;
start[q->call_offset+1].ptr =
(PTR) q->sym_p->stval.cp ;
break ;
case ST_LOCAL_ARRAY :
q->type = CA_ARRAY ;
q->sym_p->type = ST_ARRAY ;
q->sym_p->stval.array = new_ARRAY() ;
start[q->call_offset].op = A_PUSHA ;
start[q->call_offset+1].ptr =
(PTR) q->sym_p->stval.array ;
break ;
}
}
}
else
if ( q->type == ST_LOCAL_NONE )
{ /* try to infer the type */
if ( * q->type_p == ST_LOCAL_VAR )
{ /* set type , don't need to patch */
q->type = CA_EXPR ;
}
else
if ( * q->type_p == ST_LOCAL_ARRAY )
{ q->type = CA_ARRAY ;
start[q->call_offset].op = LA_PUSHA ;
/* offset+1 op is OK */
}
else /* try to infer from callee */
{
switch( callee->typev[q->arg_num] )
{
case ST_LOCAL_VAR :
q->type = CA_EXPR ;
* q->type_p = ST_LOCAL_VAR ;
/* do not need to patch */
break ;
case ST_LOCAL_ARRAY :
q->type = CA_ARRAY ;
* q->type_p = ST_LOCAL_ARRAY ;
start[q->call_offset].op = LA_PUSHA ;
break ;
}
}
}
/* if we still do not know the type put on the new list
else type check */
if ( q->type == ST_NONE || q->type == ST_LOCAL_NONE )
{
q->link = exit_list ;
exit_list = q ;
}
else /* type known */
{
if ( callee->typev[q->arg_num] == ST_LOCAL_NONE )
callee->typev[q->arg_num] = q->type ;
else
if ( q->type != callee->typev[q->arg_num] )
{
errmsg(0, "line %u: type error in arg(%d) in call to %s",
line_no, q->arg_num+1, callee->name) ;
if ( ++compile_error_count == MAX_COMPILE_ERRORS )
mawk_exit(1) ;
}
zfree(q, sizeof(CA_REC)) ;
check_progress = 1 ;
}
} /* while */
return exit_list ;
}
static int arg_cnt_ok( fbp, q, line_no )
FBLOCK *fbp ;
CA_REC *q ;
unsigned line_no ;
{
if ( q->arg_num >= fbp->nargs )
{
errmsg(0, "line %u: too many arguments in call to %s" ,
line_no, fbp->name ) ;
if ( ++compile_error_count == MAX_COMPILE_ERRORS )
mawk_exit(1) ;
return 0 ;
}
else return 1 ;
}
FCALL_REC *resolve_list ;
/* function calls whose arg types need checking
are stored on this list */
/* on first pass thru the resolve list
we check :
if forward referenced functions were really defined
if right number of arguments
and compute call_start which is now known
*/
static FCALL_REC *first_pass( p )
register FCALL_REC *p ;
{ FCALL_REC dummy ;