/radiusd/rewrite.y
Happy | 6359 lines | 5568 code | 791 blank | 0 comment | 0 complexity | 746087d6a8925f92c839b6c7df700828 MD5 | raw file
Possible License(s): GPL-3.0, CC-BY-SA-3.0, LGPL-3.0
- %{
- /* This file is part of GNU Radius.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2010, 2013 Free Software Foundation, Inc.
- Written by Sergey Poznyakoff
-
- GNU Radius is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
-
- GNU Radius is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with GNU Radius. If not, see <http://www.gnu.org/licenses/>. */
- #if defined(HAVE_CONFIG_H)
- # include <config.h>
- #endif
- #include <sys/types.h>
- #include <stdio.h>
- #include <string.h>
- #include <ctype.h>
- #include <errno.h>
- #include <radiusd.h>
- #include <setjmp.h>
- #include <rewrite.h>
- #ifdef USE_SERVER_GUILE
- # include <libguile.h>
- # include <radius/radscm.h>
- #endif
-
- typedef long RWSTYPE;
- #define RW_MIN(a,b) ((a)<(b)) ? (a) : (b)
-
- /*
- * Generalized list structure
- */
- typedef struct rw_list RWLIST;
- #define RWLIST(type) \
- type *next;\
- type *prev
- struct rw_list {
- RWLIST(RWLIST);
- };
- /*
- * Generalized object
- */
- typedef struct object_t OBJECT ;
- #define OBJ(type) \
- RWLIST(type);\
- type *alloc
- struct object_t {
- OBJ(OBJECT);
- };
- typedef struct {
- size_t size; /* Size of an element */
- void (*free)(); /* deallocator */
- OBJECT *alloc_list; /* list of allocated elements */
- } OBUCKET;
-
- /* ************************************************************
- * Basic data types
- */
- typedef int stkoff_t; /* Offset on stack */
- typedef unsigned int pctr_t; /* Program counter */
- #define RW_REG ('z'-'a'+1)
- typedef struct {
- RWSTYPE reg[RW_REG]; /* Registers */
- #define rA reg[0]
- char *sA; /* String accumulator */
- pctr_t pc; /* Program counter */
-
- RWSTYPE *stack; /* Stack+heap space */
- int stacksize; /* Size of stack */
- int st; /* Top of stack */
- int sb; /* Stack base */
- int ht; /* Top of heap */
-
- int nmatch;
- regmatch_t *pmatch;
- grad_request_t *req;
-
- jmp_buf jmp;
- } RWMACH;
- typedef void (*INSTR)(); /* program instruction */
-
- /* Compiled regular expression
- */
- typedef struct comp_regex COMP_REGEX;
- struct comp_regex {
- OBJ(COMP_REGEX);
- regex_t regex; /* compiled regex itself */
- int nmatch; /* number of \( ... \) groups */
- };
- /*
- * Binary Operations
- */
- typedef enum {
- Eq,
- Ne,
- Lt,
- Le,
- Gt,
- Ge,
- BAnd,
- BXor,
- BOr,
- And,
- Or,
- Shl,
- Shr,
- Add,
- Sub,
- Mul,
- Div,
- Rem,
- Max_opcode
- } Bopcode;
- /*
- * Unary operations
- */
- typedef enum {
- Neg,
- Not,
- Max_unary
- } Uopcode;
- /*
- * Matrix types
- */
- typedef enum {
- Generic,
- Nop,
- Enter,
- Leave,
- Stop,
- Constant,
- Matchref,
- Variable,
- Unary,
- Binary,
- Cond,
- Asgn,
- Match,
- Coercion,
- Expression,
- Return,
- Jump,
- Branch,
- Target,
- Call,
- Builtin,
- Pop,
- Pusha,
- Popa,
- Attr,
- Attr_asgn,
- Attr_check,
- Attr_delete,
- Max_mtxtype
- } Mtxtype;
- /*
- * Function parameter
- */
- typedef struct parm_t PARAMETER;
- struct parm_t {
- PARAMETER *prev; /* Previous parameter */
- PARAMETER *next; /* Next parameter */
- grad_data_type_t datatype; /* type */
- stkoff_t offset; /* Offset on stack */
- };
- /*
- * Local variable
- */
- typedef struct variable VAR;
- struct variable {
- OBJ(VAR);
- VAR *dcllink; /* Link to the next variable vithin the
- * same declaration
- */
- char *name; /* name of the variable */
- int level; /* nesting level */
- int offset; /* offset on stack */
- grad_data_type_t datatype; /* type */
- int constant; /* true if assigned a constant value */
- grad_datum_t datum; /* constant value itself */
- };
- /*
- * Function definition
- */
- typedef struct function_def {
- struct function_def *next;
- char *name; /* Function name */
- grad_data_type_t rettype; /* Return type */
- pctr_t entry; /* Code entry */
- COMP_REGEX *rx_list; /* List of compiled regexps */
- int nparm; /* Number of parameters */
- PARAMETER *parm; /* List of parameters */
- stkoff_t stack_alloc; /* required stack allocation */
- grad_locus_t loc; /* source location where the function
- * was declared
- */
- } FUNCTION;
- #define STACK_BASE 2
- /*
- * Built-in function
- */
- typedef struct {
- INSTR handler; /* Function itself */
- char *name; /* Function name */
- grad_data_type_t rettype; /* Return type */
- char *parms; /* coded parameter types */
- } builtin_t;
- /*
- * Operation matrices
- */
- typedef union mtx MTX;
- /*
- * All matrices contain the following common fields:
- * alloc- link to the previously allocated matrix.
- * It is used at the end of code generation
- * pass to free all allocated matrices.
- * next - link to the next matrix in the subexpression
- * prev - link to the previous matrix in the subexpression
- * Additionally, all expression matrices contain the field
- * `datatype' which contains the data type for this matrix.
- */
- #if defined(MAINTAINER_MODE)
- # define COMMON_MTX \
- OBJ(MTX);\
- int id;\
- grad_locus_t loc;\
- Mtxtype type;
- #else
- # define COMMON_MTX \
- OBJ(MTX);\
- grad_locus_t loc;\
- Mtxtype type;
- #endif
-
- #define COMMON_EXPR_MTX \
- COMMON_MTX\
- grad_data_type_t datatype;\
- MTX *uplink;\
- MTX *arglink;
- /*
- * Generic matrix: nothing special
- * Type: Generic
- */
- typedef struct {
- COMMON_EXPR_MTX
- } GEN_MTX;
- /*
- * Constant matrix
- * Type: Constant
- */
- typedef struct {
- COMMON_EXPR_MTX
- grad_datum_t datum; /* Constant value */
- } CONST_MTX;
- /*
- * Reference to a previous regexp: corresponds to a \N construct
- * Type: Matchref
- */
- typedef struct {
- COMMON_EXPR_MTX
- int num; /* Number of \( ... \) to be referenced */
- } MATCHREF_MTX;
- /*
- * Reference to a variable
- * Type: Variable
- */
- typedef struct {
- COMMON_EXPR_MTX
- VAR *var; /* Variable being referenced */
- } VAR_MTX;
- /*
- * Unary operation matrix
- * Type: Unary
- */
- typedef struct {
- COMMON_EXPR_MTX
- Uopcode opcode; /* Operation code */
- MTX *arg; /* Argument */
- } UN_MTX;
- /*
- * Binary operation matrix
- * Type: Binary
- */
- typedef struct {
- COMMON_EXPR_MTX
- Bopcode opcode; /* Operation code */
- MTX *arg[2]; /* Arguments */
- } BIN_MTX;
- /*
- * Assignment matrix
- * Type: Asgn
- */
- typedef struct {
- COMMON_EXPR_MTX
- VAR *lval; /* Lvalue */
- MTX *arg; /* Rvalue */
- } ASGN_MTX;
- /*
- * Conditional expression matrix
- * Type: Cond
- */
- typedef struct {
- COMMON_MTX
- MTX *expr; /* Conditional expression */
- MTX *if_true; /* Branch if true */
- MTX *if_false; /* Branch if false */
- } COND_MTX;
- /*
- * Regexp match
- * Type: Match
- */
- typedef struct {
- COMMON_EXPR_MTX
- int negated; /* Is the match negated ? */
- MTX *arg; /* Argument (lhs) */
- COMP_REGEX *rx; /* Regexp (rhs) */
- } MATCH_MTX;
- /*
- * Type coercion
- * Type: Coerce
- */
- typedef struct {
- COMMON_EXPR_MTX
- MTX *arg; /* Argument of the coercion */
- } COERCE_MTX;
- /*
- * Expression
- * Type: Expression
- */
- typedef struct {
- COMMON_EXPR_MTX
- MTX *expr;
- } EXPR_MTX;
- /*
- * Return from function
- * Type: Return
- */
- typedef struct {
- COMMON_EXPR_MTX
- MTX *expr; /* Return value */
- } RET_MTX;
- /*
- * Unconditional branch (jump)
- * Type: Jump
- */
- typedef struct {
- COMMON_MTX
- MTX *link; /* Link to the next jump matrix
- * (for break and continue matrices)
- */
- MTX *dest; /* Jump destination (usually a NOP matrix) */
- } JUMP_MTX;
- /*
- * Conditional branch
- * Type: Branch
- */
- typedef struct {
- COMMON_MTX
- int cond; /* Condition: 1 - equal, 0 - not equal */
- MTX *dest; /* Jump destination (usually a NOP matrix) */
- } BRANCH_MTX;
- /*
- * Stack frame matrix
- * Type: Enter, Leave
- */
- typedef struct {
- COMMON_MTX
- stkoff_t stacksize;/* Required stack size */
- } FRAME_MTX;
- /*
- * Jump target
- * Type: Target
- */
- typedef struct {
- COMMON_MTX
- pctr_t pc; /* Target's program counter */
- } TGT_MTX;
- /*
- * No-op matrix. It is always inserted at the branch destination
- * points. Its purpose is to keep a singly-linked list of jump
- * locations for fixing up jump statements.
- * Type: Nop
- */
- typedef struct {
- COMMON_MTX
- TGT_MTX *tgt; /* Target list */
- pctr_t pc; /* Program counter for backward
- references */
- } NOP_MTX;
- /*
- * Function call
- * Type: Call
- */
- typedef struct {
- COMMON_EXPR_MTX
- FUNCTION *fun; /* Called function */
- int nargs; /* Number of arguments */
- MTX *args; /* Arguments */
- } CALL_MTX;
- /*
- * Builtin function call
- * Type: Builtin
- */
- typedef struct {
- COMMON_EXPR_MTX
- INSTR fun; /* Handler function */
- int nargs; /* Number of arguments */
- MTX *args; /* Arguments */
- } BTIN_MTX;
- /*
- * Attribute matrix
- * Type: Attr, Attr_asgn, Attr_check
- */
- typedef struct {
- COMMON_EXPR_MTX
- int attrno; /* Attribute number */
- MTX *index; /* Index expression */
- MTX *rval; /* Rvalue */
- } ATTR_MTX;
- union mtx {
- GEN_MTX gen;
- NOP_MTX nop;
- FRAME_MTX frame;
- CONST_MTX cnst;
- MATCHREF_MTX ref;
- VAR_MTX var;
- UN_MTX un;
- BIN_MTX bin;
- COND_MTX cond;
- ASGN_MTX asgn;
- MATCH_MTX match;
- COERCE_MTX coerce;
- RET_MTX ret;
- JUMP_MTX jump;
- BRANCH_MTX branch;
- TGT_MTX tgt;
- CALL_MTX call;
- BTIN_MTX btin;
- ATTR_MTX attr;
- };
- /*
- * Stack frame
- */
- typedef struct frame_t FRAME;
- struct frame_t {
- OBJ(FRAME);
- int level; /* nesting level */
- stkoff_t stack_offset; /* offset in the stack */
- };
- /* *****************************************************************
- * Static data
- */
- /*
- * Stack Frame list
- */
- static OBUCKET frame_bkt = { sizeof(FRAME), NULL };
- static FRAME *frame_first, *frame_last;
- #define curframe frame_last
- static int errcnt; /* Number of errors detected */
- static FUNCTION *function; /* Function being compiled */
- static grad_symtab_t *rewrite_tab;/* Function table */
- static MTX *mtx_first, *mtx_last; /* Matrix list */
- static VAR *var_first, *var_last; /* Variable list */
- /*
- * Loops
- */
- typedef struct loop_t LOOP;
- struct loop_t {
- OBJ(LOOP);
- JUMP_MTX *lp_break;
- JUMP_MTX *lp_cont;
- };
- static OBUCKET loop_bkt = { sizeof(LOOP), NULL };
- static LOOP *loop_first, *loop_last;
- void loop_push(MTX *mtx);
- void loop_pop();
- void loop_fixup(JUMP_MTX *list, MTX *target);
- void loop_init();
- void loop_free_all();
- void loop_unwind_all();
- /*
- * Lexical analyzer stuff
- */
- static FILE *infile; /* Input file */
- static grad_locus_t locus; /* Input location */
- static char *inbuf; /* Input string */
- static char *curp; /* Current pointer */
-
- static int yyeof; /* rised when EOF is encountered */
- static struct obstack input_stk; /* Symbol stack */
- static grad_data_type_t return_type = Undefined;
- /* Data type of the topmost expression. */
- static int regcomp_flags = 0; /* Flags to be used with regcomps */
- #define regex_init() regcomp_flags = 0
-
- /* Runtime */
- static size_t rewrite_stack_size = 4096; /* Size of stack+heap */
- static RWSTYPE *runtime_stack;
- static RWMACH mach;
- /* Default domain for gettext functions. It is initialized to PACKAGE
- by default */
- static char *default_gettext_domain;
-
- /* ***************************************************************
- * Function declarations
- */
- /*
- * Lexical analyzer
- */
- static int yylex();
- static void yysync();
- static int yyerror(char *s);
-
- /*
- * Frames
- */
- static void frame_init();
- static void frame_push();
- static void frame_pop();
- static void frame_unwind_all();
- static void frame_free_all();
- /*
- * Variables
- */
- static void var_init();
- static VAR * var_alloc(grad_data_type_t type, char *name, int grow);
- static void var_unwind_level();
- static void var_unwind_all();
- static void var_type(grad_data_type_t type, VAR *var);
- static void var_free_all();
- static VAR *var_lookup(char *name);
- /*
- * Matrices
- */
- static void mtx_init();
- static void mtx_free_all();
- static void mtx_unwind_all();
- static MTX * mtx_cur();
- static MTX * mtx_nop();
- static MTX * mtx_jump();
- static MTX * mtx_frame(Mtxtype type, stkoff_t stksize);
- static MTX * mtx_stop();
- static MTX * mtx_pop();
- static MTX * mtx_return();
- static MTX * mtx_alloc(Mtxtype type);
- static MTX * mtx_const(grad_value_t *val);
- static MTX * mtx_ref(int num);
- static MTX * mtx_var(VAR *var);
- static MTX * mtx_asgn(VAR *var, MTX *arg);
- static MTX * mtx_bin(Bopcode opcode, MTX *arg1, MTX *arg2);
- static MTX * mtx_un(Uopcode opcode, MTX *arg);
- static MTX * mtx_match(int negated, MTX *mtx, COMP_REGEX *);
- static MTX * mtx_cond(MTX *cond, MTX *if_true, MTX *if_false);
- static MTX * mtx_coerce(grad_data_type_t type, MTX *arg);
- static MTX * mtx_call(FUNCTION *fun, MTX *args);
- static MTX * mtx_builtin(builtin_t *bin, MTX *args);
- static MTX * mtx_attr(grad_dict_attr_t *attr, MTX *index);
- static MTX * mtx_attr_asgn(grad_dict_attr_t *attr, MTX *index, MTX *rval);
- static MTX * mtx_attr_check(grad_dict_attr_t *attr, MTX *index);
- static MTX * mtx_attr_delete(grad_dict_attr_t *attr, MTX *index);
- static MTX * coerce(MTX *arg, grad_data_type_t type);
- /*
- * Regular expressions
- */
- static COMP_REGEX * rx_alloc(regex_t *regex, int nmatch);
- static void rx_free(COMP_REGEX *rx);
- static COMP_REGEX * compile_regexp(char *str);
- /*
- * Functions
- */
- static FUNCTION * function_install(FUNCTION *fun);
- static int function_free(FUNCTION *fun);
- static void function_delete();
- static void function_cleanup();
- /*
- * Built-in functions
- */
- static builtin_t * builtin_lookup(char *name);
- /*
- * Code optimizer and generator
- */
- static int optimize();
- static pctr_t codegen();
- static void code_init();
- static void code_check();
- /*
- * Auxiliary and debugging functions
- */
- static void debug_dump_code();
- static const char * datatype_str_nom(grad_data_type_t type);
- static const char * datatype_str_acc(grad_data_type_t type);
- static const char * datatype_str_abl(grad_data_type_t type);
- static grad_data_type_t attr_datatype(grad_dict_attr_t *);
- /*
- * Run-Time
- */
- static void gc();
- static void run(pctr_t pc);
- static int run_init(pctr_t pc, grad_request_t *req);
- static int rw_error(const char *msg);
- static int rw_error_free(char *msg);
-
- /* These used to lock/unlock access to rw_code array. Now this is
- not needed. However, I left the placeholders for a while... */
- #define rw_code_lock()
- #define rw_code_unlock()
- #define AVPLIST(m) ((m)->req ? (m)->req->avlist : NULL)
- static FUNCTION fmain;
- %}
- %union {
- int number;
- int type;
- VAR *var;
- MTX *mtx;
- FUNCTION *fun;
- builtin_t *btin;
- grad_dict_attr_t *attr;
- struct {
- MTX *arg_first;
- MTX *arg_last;
- } arg;
- struct {
- int nmatch;
- regex_t regex;
- } rx;
- char *string;
- };
- %token <type> TYPE
- %token IF ELSE RETURN WHILE FOR DO BREAK CONTINUE DELETE
- %token <string> STRING IDENT
- %token <number> NUMBER REFERENCE
- %token <var> VARIABLE
- %token <fun> FUN
- %token <btin> BUILTIN
- %token <attr> ATTR
- %token BOGUS
- %type <arg> arglist
- %type <mtx> stmt expr list cond else while do arg args
- %type <var> varlist parmlist parm dclparm
- %right '='
- %left OR
- %left AND
- %nonassoc MT NM
- %left '|'
- %left '^'
- %left '&'
- %left EQ NE
- %left LT LE GT GE
- %left SHL SHR
- %left '+' '-'
- %left '*' '/' '%'
- %left UMINUS NOT TYPECAST
- %%
- program : input
- {
- var_free_all();
- loop_free_all();
- frame_free_all();
- mtx_free_all();
- }
- ;
- input : dcllist
- {
- return_type = Undefined;
- }
- | expr
- {
- if (errcnt) {
- YYERROR;
- }
-
- mtx_return($1);
-
- memset(&fmain, 0, sizeof(fmain));
- fmain.name = "main";
- fmain.rettype = return_type = $1->gen.datatype;
- function = &fmain;
- if (optimize() == 0) {
- codegen();
- if (errcnt) {
- YYERROR;
- }
- }
- }
- ;
- dcllist : decl
- | dcllist decl
- | dcllist error
- {
- /* Roll back all changes done so far */
- var_unwind_all();
- loop_unwind_all();
- frame_unwind_all();
- mtx_unwind_all();
- function_delete();
- /* Synchronize input after error */
- yysync();
- /* Clear input and error condition */
- yyclearin;
- yyerrok;
- errcnt = 0;
- }
- ;
- decl : fundecl begin list end
- {
- if (errcnt) {
- function_delete();
- YYERROR;
- }
-
- if (optimize() == 0) {
- codegen();
- if (errcnt) {
- function_delete();
- YYERROR;
- }
- } else {
- function_delete();
- }
-
- /* clean up things */
- var_unwind_all();
- loop_unwind_all();
- frame_unwind_all();
- mtx_unwind_all();
- function_cleanup();
- }
- ;
- fundecl : TYPE IDENT dclparm
- {
- VAR *var;
- PARAMETER *last, *parm;
- FUNCTION f;
-
- if (errcnt)
- YYERROR;
-
- memset(&f, 0, sizeof(f));
- f.name = $2;
- f.rettype = $1;
- f.entry = 0;
- f.loc = locus;
-
- f.nparm = 0;
- f.parm = NULL;
- /* Count number of parameters */
- for (var = $3; var; var = var->next)
- f.nparm++;
- f.parm = last = NULL;
- for (var = $3; var; var = var->next) {
- parm = grad_emalloc(sizeof(*parm));
- parm->datatype = var->datatype;
- var->offset = -(STACK_BASE+
- f.nparm - var->offset);
- parm->offset = var->offset;
- parm->prev = last;
- parm->next = NULL;
- if (f.parm == NULL)
- f.parm = parm;
- else
- last->next = parm;
- last = parm;
- }
- function = function_install(&f);
- }
- | TYPE FUN dclparm
- {
- grad_log_loc(GRAD_LOG_ERR, &locus,
- _("redefinition of function `%s'"), $2->name);
- grad_log_loc(GRAD_LOG_ERR, &$2->loc,
- _("previously defined here"));
- errcnt++;
- YYERROR;
- }
- ;
- begin : obrace
- | obrace autodcl
- ;
- end : cbrace
- ;
-
- obrace : '{'
- {
- frame_push();
- }
- ;
- cbrace : '}'
- {
- var_unwind_level();
- frame_pop();
- }
- ;
- /*
- * Automatic variables
- */
- autodcl : autovar
- | autodcl autovar
- ;
- autovar : TYPE varlist ';'
- {
- var_type($1, $2);
- }
- ;
- varlist : IDENT
- {
- $$ = var_alloc(Undefined, $1, +1);
- $$->dcllink = NULL;
- }
- | varlist ',' IDENT
- {
- VAR *var = var_alloc(Undefined, $3, +1);
- var->dcllink = $1;
- $$ = var;
- }
- ;
- /*
- * Function Parameters
- */
- dclparm : '(' ')'
- {
- $$ = NULL;
- }
- | '(' parmlist ')'
- {
- $$ = $2;
- }
- ;
- parmlist: parm
- {
- /*FIXME*/
- /*$$->dcllink = NULL;*/
- }
- | parmlist ',' parm
- {
- /*$1->dcllink = $3;*/
- $$ = $1;
- }
- ;
- parm : TYPE IDENT
- {
- $$ = var_alloc($1, $2, +1);
- }
- ;
- /* Argument lists
- */
- args : /* empty */
- {
- $$ = NULL;
- }
- | arglist
- {
- $$ = $1.arg_first;
- }
- ;
- arglist : arg
- {
- $1->gen.arglink = NULL;
- $$.arg_first = $$.arg_last = $1;
- }
- | arglist ',' arg
- {
- $1.arg_last->gen.arglink = $3;
- $1.arg_last = $3;
- $$ = $1;
- }
- ;
- arg : expr
- ;
- /*
- * Statement list and individual statements
- */
- list : stmt
- | list stmt
- ;
- stmt : begin list end
- {
- $$ = $2;
- }
- | expr ';'
- {
- mtx_stop();
- mtx_pop();
- }
- | IF cond stmt
- {
- $2->cond.if_false = mtx_nop();
- $$ = mtx_cur();
- }
- | IF cond stmt else stmt
- {
- mtx_stop();
- $2->cond.if_false = $4;
- $4->nop.prev->jump.dest = mtx_nop();
- $$ = mtx_cur();
- }
- | RETURN expr ';'
- {
- /*mtx_stop();*/
- $$ = mtx_return($2);
- }
- | while cond stmt
- {
- MTX *mtx;
-
- mtx_stop();
- mtx = mtx_jump();
- mtx->jump.dest = $1;
- $2->cond.if_false = mtx_nop();
- $$ = mtx_cur();
-
- /* Fixup possible breaks */
- loop_fixup(loop_last->lp_break, $$);
- /* Fixup possible continues */
- loop_fixup(loop_last->lp_cont, $1);
- loop_pop();
- }
- | do stmt { $<mtx>$ = mtx_nop(); } WHILE cond ';'
- {
- /* Default cond rule sets if_true to the next NOP matrix
- * Invert this behaviour.
- */
- $5->cond.if_false = $5->cond.if_true;
- $5->cond.if_true = $1;
- $$ = mtx_cur();
- /* Fixup possible breaks */
- loop_fixup(loop_last->lp_break, $$);
- /* Fixup possible continues */
- loop_fixup(loop_last->lp_cont, $<mtx>3);
- loop_pop();
- }
- /* ***********************
- For future use:
- | FOR '(' for_expr for_expr for_expr ')' stmt
- *********************** */
- | BREAK ';'
- {
- if (!loop_last) {
- grad_log_loc(GRAD_LOG_ERR, &locus,
- "%s",
- _("nothing to break from"));
- errcnt++;
- YYERROR;
- }
- $$ = mtx_jump();
- $$->jump.link = (MTX*)loop_last->lp_break;
- loop_last->lp_break = (JUMP_MTX*)$$;
- }
- | CONTINUE ';'
- {
- if (!loop_last) {
- grad_log_loc(GRAD_LOG_ERR, &locus,
- "%s",
- _("nothing to continue"));
- errcnt++;
- YYERROR;
- }
- $$ = mtx_jump();
- $$->jump.link = (MTX*)loop_last->lp_cont;
- loop_last->lp_cont = (JUMP_MTX*)$$;
- }
- | DELETE ATTR ';'
- {
- $$ = mtx_attr_delete($2, NULL);
- }
- | DELETE ATTR '(' expr ')' ';'
- {
- $$ = mtx_attr_delete($2, $4);
- }
- ;
- while : WHILE
- {
- $$ = mtx_nop();
- loop_push($$);
- }
- ;
- do : DO
- {
- $$ = mtx_nop();
- loop_push($$);
- }
- ;
- else : ELSE
- {
- mtx_stop();
- mtx_jump();
- $$ = mtx_nop();
- }
- ;
- cond : '(' expr ')'
- {
- mtx_stop();
- $$ = mtx_cond($2, NULL, NULL);
- $$->cond.if_true = mtx_nop();
- }
- ;
- /*
- * Expressions
- */
- expr : NUMBER
- {
- grad_value_t val;
- val.type = Integer;
- val.datum.ival = $1;
- $$ = mtx_const(&val);
- }
- | STRING
- {
- grad_value_t val;
- val.type = String;
- val.datum.sval.size = strlen($1);
- val.datum.sval.data = $1;
- $$ = mtx_const(&val);
- }
- | REFERENCE
- {
- $$ = mtx_ref($1);
- }
- | VARIABLE
- {
- $$ = mtx_var($1);
- }
- | IDENT
- {
- grad_log_loc(GRAD_LOG_ERR, &locus, _("undefined variable: %s"), $1);
- errcnt++;
- YYERROR;
- }
- | VARIABLE '=' expr
- {
- $$ = mtx_asgn($1, $3);
- }
- | ATTR
- {
- $$ = mtx_attr($1, NULL);
- }
- | ATTR '(' expr ')'
- {
- $$ = mtx_attr($1, $3);
- }
- | '*' ATTR
- {
- $$ = mtx_attr_check($2, NULL);
- }
- | '*' ATTR '(' expr ')'
- {
- $$ = mtx_attr_check($2, $4);
- }
- | ATTR '=' expr
- {
- $$ = mtx_attr_asgn($1, NULL, $3);
- }
- | ATTR '(' expr ')' '=' expr
- {
- $$ = mtx_attr_asgn($1, $3, $6);
- }
- | FUN '(' args ')'
- {
- $$ = mtx_call($1, $3);
- }
- | BUILTIN '(' args ')'
- {
- $$ = mtx_builtin($1, $3);
- }
- | expr '+' expr
- {
- $$ = mtx_bin(Add, $1, $3);
- }
- | expr '-' expr
- {
- $$ = mtx_bin(Sub, $1, $3);
- }
- | expr '*' expr
- {
- $$ = mtx_bin(Mul, $1, $3);
- }
- | expr '/' expr
- {
- $$ = mtx_bin(Div, $1, $3);
- }
- | expr '%' expr
- {
- $$ = mtx_bin(Rem, $1, $3);
- }
- | expr '|' expr
- {
- $$ = mtx_bin(BOr, $1, $3);
- }
- | expr '&' expr
- {
- $$ = mtx_bin(BAnd, $1, $3);
- }
- | expr '^' expr
- {
- $$ = mtx_bin(BXor, $1, $3);
- }
- | expr SHL expr
- {
- $$ = mtx_bin(Shl, $1, $3);
- }
- | expr SHR expr
- {
- $$ = mtx_bin(Shr, $1, $3);
- }
- | expr AND expr
- {
- $$ = mtx_bin(And, $1, $3);
- }
- | expr OR expr
- {
- $$ = mtx_bin(Or, $1, $3);
- }
- | '-' expr %prec UMINUS
- {
- $$ = mtx_un(Neg, $2);
- }
- | '+' expr %prec UMINUS
- {
- $$ = $2;
- }
- | NOT expr
- {
- $$ = mtx_un(Not, $2);
- }
- | '(' expr ')'
- {
- $$ = $2;
- }
- | '(' TYPE ')' expr %prec TYPECAST
- {
- $$ = mtx_coerce($2, $4);
- }
- | expr EQ expr
- {
- $$ = mtx_bin(Eq, $1, $3);
- }
- | expr NE expr
- {
- $$ = mtx_bin(Ne, $1, $3);
- }
- | expr LT expr
- {
- $$ = mtx_bin(Lt, $1, $3);
- }
- | expr LE expr
- {
- $$ = mtx_bin(Le, $1, $3);
- }
- | expr GT expr
- {
- $$ = mtx_bin(Gt, $1, $3);
- }
- | expr GE expr
- {
- $$ = mtx_bin(Ge, $1, $3);
- }
- | expr MT STRING
- {
- COMP_REGEX *rx;
- if ((rx = compile_regexp($3)) == NULL) {
- errcnt++;
- YYERROR;
- }
- $$ = mtx_match(0, $1, rx);
- }
- | expr NM STRING
- {
- COMP_REGEX *rx;
- if ((rx = compile_regexp($3)) == NULL) {
- errcnt++;
- YYERROR;
- }
- $$ = mtx_match(1, $1, rx);
- }
- ;
- %%
- int
- yyerror(char *s)
- {
- grad_log_loc(GRAD_LOG_ERR, &locus, "%s", s);
- errcnt++;
- return 0;
- }
- /* **************************************************************************
- * Interface functions
- */
- int
- parse_rewrite(char *path)
- {
- locus.file = path;
- infile = fopen(locus.file, "r");
- if (!infile) {
- if (errno != ENOENT) {
- grad_log(GRAD_LOG_ERR|GRAD_LOG_PERROR,
- _("can't open file `%s'"),
- locus.file);
- return -1;
- }
- return -2;
- }
- GRAD_DEBUG1(1, "Loading file %s", locus.file);
- rw_code_lock();
- yyeof = 0;
- locus.line = 1;
- errcnt = 0;
- regex_init();
- obstack_init(&input_stk);
- mtx_init();
- var_init();
- loop_init();
- frame_init();
-
- frame_push();
-
- yyparse();
- var_free_all();
- frame_free_all();
- mtx_free_all();
-
- fclose(infile);
- obstack_free(&input_stk, NULL);
- rw_code_unlock();
- return errcnt;
- }
- static int
- parse_rewrite_string(char *str)
- {
- rw_code_lock();
- code_check();
- yyeof = 0;
- locus.file = "<string>";
- locus.line = 1;
- errcnt = 0;
- regex_init();
- obstack_init(&input_stk);
- mtx_init();
- var_init();
- loop_init();
- frame_init();
-
- frame_push();
-
- if (GRAD_DEBUG_LEVEL(50))
- yydebug++;
- infile = 0;
- inbuf = curp = str;
-
- yyparse();
- #if defined(MAINTAINER_MODE)
- if (GRAD_DEBUG_LEVEL(100))
- debug_dump_code();
- #endif
-
- var_free_all();
- frame_free_all();
- mtx_free_all();
-
- obstack_free(&input_stk, NULL);
- rw_code_unlock();
- return errcnt;
- }
- /* **************************************************************************
- * Lexical analyzer stuff: too simple to be written in lex.
- */
- static int
- unput(int c)
- {
- if (!c)
- return 0;
- if (infile)
- ungetc(c, infile);
- else if (curp > inbuf)
- *--curp = c;
- return c;
- }
- static int
- input()
- {
- if (yyeof)
- yychar = 0;
- else if (infile) {
- if ((yychar = getc(infile)) <= 0) {
- yyeof++;
- yychar = 0;
- }
- } else if (curp) {
- yychar = *curp++;
- if (!yychar)
- yyeof++;
- }
- return yychar;
- }
- static int rw_backslash();
- static int c2d(int c);
- static int read_number();
- static int read_num(int n, int base);
- static char *read_string();
- static char *read_ident(int c);
- static char *read_to_delim(int c);
- static int skip_to_nl();
- static int c_comment();
- /*
- * Convert a character to digit. Only octal, decimal and hex digits are
- * allowed. If any other character is input, c2d() returns 100, which is
- * greater than any number base allowed.
- */
- int
- c2d(int c)
- {
- switch (c) {
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- return c - '0';
- case 'A':
- case 'B':
- case 'C':
- case 'D':
- case 'E':
- case 'F':
- return c - 'A' + 16;
- case 'a':
- case 'b':
- case 'c':
- case 'd':
- case 'e':
- case 'f':
- return c - 'a' + 10;
- }
- return 100;
- }
- /*
- * Read a number. Usual C conventions apply.
- */
- int
- read_number()
- {
- int c;
- int base;
- int res;
-
- c = yychar;
- if (c == '0') {
- if (input() == 'x' || yychar == 'X') {
- base = 16;
- } else {
- base = 8;
- unput(yychar);
- }
- } else
- base = 10;
- res = read_num(c2d(c), base);
- if (base == 10 && yychar == '.') {
- int n;
- for (n = 0; n < 3 && yychar == '.'; n++) {
- int val;
-
- input();
- val = read_num(0, base);
- res = (res << 8) + val;
- }
- if (n != 3)
- res <<= 8 * (3-n);
- }
- return res;
- }
- int
- read_num(int n, int base)
- {
- int d;
- while (input() && (d = c2d(yychar)) < 16)
- n = n*base + d;
- unput(yychar);
- return n;
- }
- int
- rw_backslash()
- {
- switch (input()) {
- case '\\':
- return '\\';
- case 'a':
- return '\a';
- case 'b':
- return '\b';
- case 'f':
- return '\f';
- case 'n':
- return '\n';
- case 'r':
- return '\r';
- case 't':
- return '\t';
- case 'e':
- return '\033';
- case '0':
- return read_number();
- case 'x':
- case 'X':
- return read_num(0, 16);
- case '(':
- case ')':
- /* Preserve regular expressions */
- unput(yychar);
- yychar = '\\';
- }
- return yychar;
- }
- /*
- * Read a string up to the closing doublequote
- */
- char *
- read_string()
- {
- while (input() && yychar != '"') {
- if (yychar == '\\')
- yychar = rw_backslash();
- obstack_1grow(&input_stk, yychar);
- }
- obstack_1grow(&input_stk, 0);
- return obstack_finish(&input_stk);
- }
- /*
- * Read everything up to the given delimiter
- */
- char *
- read_to_delim(int c)
- {
- while (input() && yychar != c)
- obstack_1grow(&input_stk, yychar);
- obstack_1grow(&input_stk, 0);
- return obstack_finish(&input_stk);
- }
- /*
- * Is `c' a part of the word?
- */
- #define isword(c) (isalnum(c) || c == '_' || c == '$')
- /*
- * Is `c' a whitespace character?
- */
- #define isws(c) ((c) == ' ' || (c) == '\t')
- /*
- * Read identifier
- */
- char *
- read_ident(int c)
- {
- obstack_1grow(&input_stk, c);
- while (input() && isword(yychar))
- obstack_1grow(&input_stk, yychar);
- obstack_1grow(&input_stk, 0);
- unput(yychar);
- return obstack_finish(&input_stk);
- }
- /*
- * Skip input up to the next newline
- */
- int
- skip_to_nl()
- {
- while (input() && yychar != '\n')
- ;
- return unput(yychar);
- }
- /*
- * Skip a C-style comment
- */
- int
- c_comment()
- {
- if (yychar != '/')
- return 0;
- if (input() == '*') {
- size_t keep_line = locus.line;
- do {
- while (input() != '*') {
- if (yychar == 0) {
- grad_log_loc(GRAD_LOG_ERR, &locus,
- _("unexpected EOF in comment started at line %lu"),
- (unsigned long) keep_line);
- return 0;
- } else if (yychar == '\n')
- locus.line++;
- }
- } while (input() != '/');
- return 1;
- }
- unput(yychar);
- yychar = '/';
- return 0;
- }
- /* Pragmatic comments */
- enum pragma_handler_phase {
- pragma_begin,
- pragma_cont,
- pragma_error,
- pragma_end
- };
- typedef int (*pragma_handler_fp) (enum pragma_handler_phase);
- static int
- regex_pragma (enum pragma_handler_phase phase)
- {
- int disable = 0;
- int bit;
- char *s;
- static int regexp_accum;
-
- switch (phase) {
- case pragma_begin:
- regexp_accum = 0;
- return 0;
-
- case pragma_end:
- regcomp_flags = regexp_accum;
- return 0;
- case pragma_error:
- return 0;
-
- case pragma_cont:
- break;
- }
- switch (yychar) {
- case '+':
- disable = 0;
- input();
- break;
- case '-':
- disable = 1;
- input();
- break;
- }
- if (!isword(yychar)) {
- grad_log_loc(GRAD_LOG_ERR, &locus, _("Malformed pragma"));
- return 1;
- }
-
- s = read_ident(yychar);
- if (strcmp (s, "extended") == 0)
- bit = REG_EXTENDED;
- else if (strcmp (s, "icase") == 0)
- bit = REG_ICASE;
- else if (strcmp (s, "newline") == 0)
- bit = REG_NEWLINE;
- else {
- grad_log_loc(GRAD_LOG_ERR, &locus,
- _("Unknown regexp flag: %s"), s);
- return 1;
- }
- if (disable)
- regexp_accum &= ~bit;
- else
- regexp_accum |= bit;
- return 0;
- }
- static pragma_handler_fp
- find_pragma_handler(char *s)
- {
- if (strcmp(s, "regex") == 0)
- return regex_pragma;
- return NULL;
- }
- static void
- handle_pragma()
- {
- int rc;
- pragma_handler_fp pragma_handler;
-
- while (input() && isws(yychar))
- ;
- if (yychar == 0)
- return;
-
- pragma_handler = find_pragma_handler (read_ident(yychar));
-
- if (pragma_handler) {
- pragma_handler(pragma_begin);
- do {
- while (input() && isws(yychar))
- ;
- if (yychar == 0 || yychar == '\n')
- break;
- rc = pragma_handler(pragma_cont);
- } while (rc == 0 && yychar != '\n' && yychar != 0);
-
- pragma_handler(rc ? pragma_error : pragma_end);
- }
- }
- /* Parse a 'sharp' (single-line) comment */
- void
- sharp_comment()
- {
- while (input() && isws(yychar))
- ;
- if (yychar == 0)
- return;
- else if (yychar == '\n') {
- locus.line++;
- return;
- } else if (isword(yychar)) {
- if (strcmp(read_ident(yychar), "pragma") == 0)
- handle_pragma();
- }
-
- skip_to_nl();
- }
- #if defined(MAINTAINER_MODE)
- # define DEBUG_LEX1(s) if (GRAD_DEBUG_LEVEL(60)) printf("yylex: " s "\n")
- # define DEBUG_LEX2(s,v) if (GRAD_DEBUG_LEVEL(60)) printf("yylex: " s "\n", v)
- #else
- # define DEBUG_LEX1(s)
- # define DEBUG_LEX2(s,v)
- #endif
- static grad_keyword_t rw_kw[] = {
- { "if", IF },
- { "else", ELSE },
- { "return", RETURN },
- { "for", FOR },
- { "do", DO },
- { "while", WHILE },
- { "break", BREAK },
- { "continue", CONTINUE },
- { "delete", DELETE },
- { NULL }
- };
- int
- yylex()
- {
- int nl;
- int c;
- VAR *var;
- FUNCTION *fun;
- builtin_t *btin;
-
- /* Skip whitespace and comment lines */
- do {
- nl = 0;
- while (input() && isspace(yychar))
- if (yychar == '\n')
- locus.line++;
-
- if (!yychar)
- return 0;
- if (yychar == '#') {
- sharp_comment();
- nl = 1;
- }
- } while (nl || c_comment());
- /*
- * A regexp reference
- */
- if (yychar == '\\') {
- input();
- yylval.number = read_number();
- DEBUG_LEX2("REFERENCE %d", yylval.number);
- return REFERENCE;
- }
- /*
- * A character
- */
- if (yychar == '\'') {
- if (input() == '\\')
- c = rw_backslash();
- else
- c = yychar;
- if (input() != '\'') {
- grad_log_loc(GRAD_LOG_ERR, &locus,
- "%s",
- _("unterminated character constant"));
- errcnt++;
- }
- yylval.number = c;
- DEBUG_LEX2("CHAR %d", c);
- return NUMBER;
- }
-
- /*
- * A number
- */
- if (isdigit(yychar)) {
- yylval.number = read_number();
- DEBUG_LEX2("NUMBER %d", yylval.number);
- return NUMBER;
- }
- /*
- * Quoted string
- */
- if (yychar == '"') {
- yylval.string = read_string();
- DEBUG_LEX2("STRING %s", yylval.string);
- return STRING;
- }
- /* A/V pair reference.
- We do not allow %<number> sequences, since it would result
- in conflict with binary '%' operator.
- Thanks to Clement Gerouville for noticing. */
- if (yychar == '%') {
- grad_dict_attr_t *attr = 0;
- char *attr_name;
-
- input();
- if (yychar == '[' || yychar == '{') {
- attr_name = read_to_delim(yychar == '[' ? ']' : '}');
- attr = grad_attr_name_to_dict(attr_name);
- } else {
- unput(yychar);
- return '%';
- }
- if (!attr) {
- grad_log_loc(GRAD_LOG_ERR, &locus,
- _("unknown attribute `%s'"),
- attr_name);
- errcnt++;
- return BOGUS;
- }
- yylval.attr = attr;
- DEBUG_LEX2("ATTR: %s", attr->name);
- return ATTR;
- }
-
-
- /*
- * Data type or identifier
- */
- if (isword(yychar)) {
- yylval.string = read_ident(yychar);
- if (strcmp(yylval.string, "integer") == 0) {
- DEBUG_LEX1("TYPE(Integer)");
- yylval.type = Integer;
- return TYPE;
- } else if (strcmp(yylval.string, "string") == 0) {
- DEBUG_LEX1("TYPE(String)");
- yylval.type = String;
- return TYPE;
- }
-
- if ((c = grad_xlat_keyword(rw_kw, yylval.string, 0)) != 0) {
- DEBUG_LEX2("KW: %s", yylval.string);
- return c;
- }
- if (var = var_lookup(yylval.string)) {
- DEBUG_LEX2("VARIABLE: %s", yylval.string);
- yylval.var = var;
- return VARIABLE;
- }
-
- if (fun = (FUNCTION*) grad_sym_lookup(rewrite_tab, yylval.string)) {
- DEBUG_LEX2("FUN %s", yylval.string);
- yylval.fun = fun;
- return FUN;
- }
- if (btin = builtin_lookup(yylval.string)) {
- DEBUG_LEX2("BUILTIN %s", yylval.string);
- yylval.btin = btin;
- return BUILTIN;
- }
- DEBUG_LEX2("IDENT: %s", yylval.string);
- return IDENT;
- }
- /*
- * Boolean expressions
- */
- if (yychar == '&' || yychar == '|') {
- int c = yychar;
- if (input() == c) {
- DEBUG_LEX2("%s", yychar == '&' ? "AND" : "OR");
- return yychar == '&' ? AND : OR;
- }
- unput(yychar);
-
- DEBUG_LEX2("%c", c);
- return c;
- }
-
- /*
- * Comparison operator
- */
- if (strchr("<>=!", yychar)) {
- int c = yychar;
- if (input() == '=') {
- switch (c) {
- case '<':
- DEBUG_LEX1("LE");
- return LE;
- case '>':
- DEBUG_LEX1("GE");
- return GE;
- case '=':
- DEBUG_LEX1("EQ");
- return EQ;
- case '!':
- DEBUG_LEX1("NE");
- return NE;
- }
- } else if (c == yychar) {
- if (c == '<') {
- DEBUG_LEX1("SHL");
- return SHL;
- }
- if (c == '>') {
- DEBUG_LEX1("SHR");
- return SHR;
- }
- unput(yychar);
- DEBUG_LEX2("%c", yychar);
- return yychar;
- } else if (yychar == '~') {
- if (c == '=') {
- DEBUG_LEX1("MT");
- return MT;
- }
- if (c == '!') {
- DEBUG_LEX1("NM");
- return NM;
- }
- }
- unput(yychar);
- switch (c) {
- case '<':
- DEBUG_LEX1("LT");
- return LT;
- case '>':
- DEBUG_LEX1("GT");
- return GT;
- case '!':
- DEBUG_LEX1("NOT");
- return NOT;
- default:
- return c;
- }
- }
- DEBUG_LEX2("%c", yychar);
- return yychar;
- }
- void
- yysync()
- {
- while (skip_to_nl() == '\n' && !isalpha(input()))
- locus.line++;
- unput(yychar);
- }
- /* ****************************************************************************
- * Generalized list functions
- */
- static RWLIST *_list_insert(RWLIST **first, RWLIST **last, RWLIST *prev,
- RWLIST *obj, int before);
- static RWLIST *_list_remove(RWLIST **first, RWLIST **last, RWLIST *obj);
- static RWLIST *_list_append(RWLIST **first, RWLIST **last, RWLIST *obj);
- #define rw_list_insert(first, last, prev, obj, before) \
- _list_insert((RWLIST**)first,(RWLIST**)last,(RWLIST*)prev,(RWLIST*)obj, before)
- #define rw_list_remove(first, last, obj) \
- _list_remove((RWLIST**)first,(RWLIST**)last,(RWLIST *)obj)
- #define rw_list_append(first, last, obj) \
- _list_append((RWLIST**)first, (RWLIST**)last, (RWLIST*)obj)
-
- RWLIST *
- _list_append(RWLIST **first, RWLIST **last, RWLIST *obj)
- {
- return rw_list_insert(first, last, *last, obj, 0);
- }
- RWLIST *
- _list_insert(RWLIST **first, RWLIST **last, RWLIST *prev, RWLIST *obj,
- int before)
- {
- RWLIST *next;
- /*
- * No first element: initialize whole list
- */
- if (!*first) {
- *first = obj;
- if (last)
- *last = obj;
- obj->prev = obj->next = NULL;
- return obj;
- }
- /*
- * Insert before `prev'
- */
- if (before) {
- _list_insert(first, last, prev, obj, 0);
- _list_remove(first, last, prev);
- _list_insert(first, last, obj, prev, 0);
- return obj;
- }
- /*
- * Default: insert after prev
- */
- obj->prev = prev;
- obj->next = prev->next;
-
- if (next = prev->next)
- next->prev = obj;
- prev->next = obj;
- if (last && prev == *last)
- *last = obj;
-
- return obj;
- }
- RWLIST *
- _list_remove(RWLIST **first, RWLIST **last, RWLIST *obj)
- {
- RWLIST *temp;
- if (temp = obj->prev)
- temp->next = obj->next;
- else
- *first = obj->next;
- if (temp = obj->next)
- temp->prev = obj->prev;
- else if (last)
- *last = obj->prev;
- obj->prev = obj->next = NULL;
-
- return obj;
- }
- /* ****************************************************************************
- * Generalized object handling
- */
- void *obj_alloc(OBUCKET *bucket);
- void obj_free_all(OBUCKET *bucket);
-
- void *
- obj_alloc(OBUCKET *bucket)
- {
- OBJECT *optr;
- optr = grad_emalloc(bucket->size);
- optr->alloc = bucket->alloc_list;
- bucket->alloc_list = optr;
-
- return optr;
- }
- void
- obj_free_all(OBUCKET *bucket)
- {
- OBJECT *obj, *next;
- obj = bucket->alloc_list;
- while (obj) {
- next = obj->alloc;
- if (bucket->free)
- bucket->free(obj);
- grad_free(obj);
- obj = next;
- }
- bucket->alloc_list = NULL;
- }
- /* **************************************************************************
- * Frames
- */
- void
- frame_init()
- {
- frame_bkt.alloc_list = NULL;
- frame_first = frame_last = NULL;
- }
- void
- frame_push()
- {
- FRAME *this_frame = obj_alloc(&frame_bkt);
- if (!frame_last) {
- this_frame->level = 0;
- this_frame->stack_offset = 0;
- } else {
- if (frame_last->level == 0)
- this_frame->stack_offset = 1;
- else
- this_frame->stack_offset = frame_last->stack_offset;
- this_frame->level = frame_last->level + 1;
- }
- rw_list_append(&frame_first, &frame_last, this_frame);
- }
- void
- frame_pop()
- {
- rw_list_remove(&frame_first, &frame_last, frame_last);
- }
- void
- frame_update_alloc()
- {
- FRAME *this_frame = frame_last;
- if (this_frame->stack_offset > function->stack_alloc)
- function->stack_alloc = this_frame->stack_offset;
- }
- void
- frame_free_all()
- {
- obj_free_all(&frame_bkt);
- frame_first = frame_last = NULL;
- }
- void
- frame_unwind_all()
- {
- while (frame_last)
- rw_list_remove(&frame_first, &frame_last, frame_last);
- frame_push();
- }
- /* **************************************************************************
- * Loops
- */
- void
- loop_init()
- {
- loop_bkt.alloc_list = NULL;
- loop_first = loop_last = NULL;
- }
- void
- loop_free_all()
- {
- obj_free_all(&loop_bkt);
- loop_first = loop_last = NULL;
- }
- void
- loop_unwind_all()
- {
- loop_first = loop_last = NULL;
- }
- /*ARGSUSED*/
- void
- loop_push(MTX *mtx)
- {
- LOOP *this_loop = obj_alloc(&loop_bkt);
- rw_list_append(&loop_first, &loop_last, this_loop);
- }
- void
- loop_pop()
- {
- rw_list_remove(&loop_first, &loop_last, loop_last);
- }
- void
- loop_fixup(JUMP_MTX *list, MTX *target)
- {
- JUMP_MTX *jp;
- for (jp = list; jp; jp = (JUMP_MTX*)jp->link)
- jp->dest = target;
- }
- /* **************************************************************************
- * Variables
- */
- OBUCKET var_bucket = { sizeof(VAR), NULL };
- void
- var_init()
- {
- var_bucket.alloc_list = NULL;
- var_first = var_last = NULL;
- }
- VAR *
- var_alloc(grad_data_type_t type, char *name, int grow)
- {
- VAR *var;
- var = (VAR*) obj_alloc(&var_bucket);
- rw_list_append(&var_first, &var_last, var);
- /* Initialize fields */
- var->name = name;
- var->datatype = type;
- var->level = curframe->level;
- var->offset = curframe->stack_offset;
- curframe->stack_offset += grow;
- return var;
- }
- void
- var_unwind_level()
- {
- int cnt = 0;
-
- while (var_last && var_last->level == curframe->level) {
- rw_list_remove(&var_first, &var_last, var_last);
- cnt++;
- }
- if (cnt)
- frame_update_alloc();
- }
- void
- var_unwind_all()
- {
- while (var_last)
- rw_list_remove(&var_first, &var_last, var_last);
- }
- void
- var_type(grad_data_type_t type, VAR *var)
- {
- for (; var; var = var->dcllink)
- var->datatype = type;
- }
- void
- var_free_all()
- {
- obj_free_all(&var_bucket);
- var_first = var_last = NULL;
- }
- VAR *
- var_lookup(char *name)
- {
- VAR *var;
- var = var_last;
- while (var && strcmp(var->name, name))
- var = var->prev;
- return var;
- }
- /* **************************************************************************
- * Matrix generation
- */
- OBUCKET mtx_bucket = { sizeof(MTX), NULL };
- #if defined(MAINTAINER_MODE)
- int mtx_current_id ;
- #endif
- /*
- * Insert a matrix into list
- */
- #define mtx_remove(mtx) rw_list_remove(&mtx_first, &mtx_last, mtx)
- #define mtx_append(mtx) rw_list_append(&mtx_first, &mtx_last, mtx)
- void
- mtx_insert(MTX *prev, MTX *mtx)
- {
- MTX *up;
- rw_list_insert(&mtx_first, &mtx_last, prev, mtx, 0);
- if (up = prev->gen.uplink) {
- switch (up->gen.type) {
- case Unary:
- up->un.arg = mtx;
- break;
- case Binary:
- if (up->bin.arg[0] == prev)
- up->bin.arg[0] = mtx;
- else
- up->bin.arg[1] = mtx;
- break;
- case Return:
- up->ret.expr = mtx;
- break;
- default:
- /*should not happen*/
- break;
- }
- }
- }
- void
- mtx_init()
- {
- mtx_bucket.alloc_list = NULL;
- mtx_first = mtx_last = NULL;
- }
- void
- mtx_unwind_all()
- {
- while (mtx_last)
- rw_list_remove(&mtx_first, &mtx_last, mtx_last);
- }
- void
- mtx_free_all()
- {
- obj_free_all(&mtx_bucket);
- mtx_first = mtx_last = NULL;
- }
- MTX *
- mtx_cur()
- {
- return mtx_last;
- }
- MTX *
- mtx_frame(Mtxtype type, stkoff_t stksize)
- {
- FRAME_MTX *mtx = (FRAME_MTX *)mtx_alloc(type);
- mtx_append(mtx);
- mtx->stacksize = stksize;
- return (MTX*)mtx;
- }
- MTX *
- mtx_nop()
- {
- MTX *mtx = mtx_alloc(Nop);
- mtx_append(mtx);
- return mtx;
- }
- MTX *
- mtx_jump()
- {
- MTX *mtx = mtx_alloc(Jump);
- mtx_append(mtx);
- return mtx;
- }
- MTX *
- mtx_stop()
- {
- MTX *mtx = mtx_alloc(Stop);
- mtx_append(mtx);
- return mtx;
- }
- MTX *
- mtx_pop()
- {
- MTX *mtx = mtx_alloc(Pop);
- mtx_append(mtx);
- return mtx;
- }
-
- MTX *
- mtx_return(MTX *arg)
- {
- MTX *mtx = mtx_alloc(Return);
- mtx_append(mtx);
- mtx->ret.expr = arg;
- arg->gen.uplink = (MTX*)mtx;
- return (MTX*)mtx;
- }
- /*
- * Allocate a matrix of given type and append it to the list
- */
- MTX *
- mtx_alloc(Mtxtype type)
- {
- MTX *mtx = obj_alloc(&mtx_bucket);
- mtx->gen.type = type;
- mtx->gen.loc = locus;
- #if defined(MAINTAINER_MODE)
- mtx->gen.id = mtx_current_id++;
- #endif
- return mtx;
- }
- /*
- * Create a Constant matrix
- */
- MTX *
- mtx_const(grad_value_t *val)
- {
- CONST_MTX *mtx = (CONST_MTX *)mtx_alloc(Constant);
-
- mtx_append(mtx);
- mtx->datatype = val->type;
- mtx->datum = val->datum;
- return (MTX*)mtx;
- }
- /*
- * Create a Reference matrix
- */
- MTX *
- mtx_ref(int num)
- {
- MATCHREF_MTX *mtx = (MATCHREF_MTX*)mtx_alloc(Matchref);
- mtx_append(mtx);
- mtx->datatype = String;
- mtx->num = num;
- return (MTX*)mtx;
- }
- MTX *
- mtx_var(VAR *var)
- {
- VAR_MTX *mtx = (VAR_MTX*)mtx_alloc(Variable);
- mtx_append(mtx);
- mtx->datatype = var->datatype;
- mtx->var = var;
- return (MTX*)mtx;
- }
- MTX *
- mtx_asgn(VAR *var, MTX *arg)
- {
- ASGN_MTX *mtx = (ASGN_MTX*)mtx_alloc(Asgn);
- mtx_append(mtx);
- if (var->datatype != arg->gen.datatype)
- coerce(arg, var->datatype);
- mtx->datatype = var->datatype;
- mtx->lval = var;
- mtx->arg = arg;
- return (MTX*)mtx;
- }
- grad_data_type_t
- attr_datatype(grad_dict_attr_t *attr)
- {
- switch (attr->type) {
- case GRAD_TYPE_STRING:
- /* FIXME: It could be a nice move to do
-
- (attr->prop & GRAD_AP_BINARY_STRING) ? Binstr : String;
- instead... */
- return String;
- case GRAD_TYPE_DATE:
- return String;
- case GRAD_TYPE_INTEGER:
- case GRAD_TYPE_IPADDR:
- return Integer;
- default:
- grad_insist_fail("unknown attribute type");
- }
- /*NOTREACHED*/
- }
- MTX *
- mtx_attr(grad_dict_attr_t *attr, MTX *index)
- {
- ATTR_MTX *mtx = (ATTR_MTX*)mtx_alloc(Attr);
- mtx_append(mtx);
- mtx->attrno = attr->value;
- mtx->datatype = attr_datatype(attr);
- mtx->index = index;
- return (MTX*)mtx;
- }
- MTX *
- mtx_attr_check(grad_dict_attr_t *attr, MTX *index)
- {
- ATTR_MTX *mtx = (ATTR_MTX*)mtx_alloc(Attr_check);
- mtx_append(mtx);
- mtx->attrno = attr->value;
- mtx->datatype = Integer;
- mtx->index = index;
- return (MTX*)mtx;
- }
- void
- rw_coercion_warning(grad_data_type_t from, grad_data_type_t to, char *pref)
- {
- grad_log_loc(GRAD_LOG_WARN, &locus,
- _("%s implicit coercion %s %s"),
- pref ? pref : "",
- datatype_str_abl(from),
- datatype_str_acc(to));
- }
- MTX *
- mtx_attr_asgn(grad_dict_attr_t *attr, MTX *index, MTX *rval)
- {
- ATTR_MTX *mtx = (ATTR_MTX*)mtx_alloc(Attr_asgn);
- mtx_append(mtx);
- mtx->attrno = attr->value;
- mtx->datatype = attr_datatype(attr);
- if (rval->gen.datatype != mtx->datatype) {
- rw_coercion_warning(rval->gen.datatype, mtx->datatype, NULL);
- rval = coerce(rval, mtx->datatype);
- }
- mtx->index = index;
- mtx->rval = rval;
- return (MTX*)mtx;
- }
- MTX *
- mtx_attr_delete(grad_dict_attr_t *attr, MTX *index)
- {
- ATTR_MTX *mtx = (ATTR_MTX*)mtx_alloc(Attr_delete);
- mtx_append(mtx);
- mtx->attrno = attr->value;
- mtx->datatype = attr_datatype(attr);
- mtx->index = index;
- return (MTX*)mtx;
- }
- MTX *
- mtx_bin(Bopcode opcode, MTX *arg1, MTX *arg2)
- {
- BIN_MTX *mtx = (BIN_MTX*)mtx_alloc(Binary);
- mtx_append(mtx);
- if (arg1->gen.datatype != arg2->gen.datatype) {
- rw_coercion_warning(String, Integer, NULL);
- if (arg1->gen.datatype == String)
- arg1 = coerce(arg1, Integer);
- else
- arg2 = coerce(arg2, Integer);
- }
- switch (arg1->gen.datatype) {
- case String:
- switch (opcode) {
- case Add:
- mtx->datatype = String;
- break;
- case Eq:
- case Ne:
- case Lt:
- case Le:
- case Gt:
- case Ge:
- mtx->datatype = Integer;
- break;
- default:
- grad_log_loc(GRAD_LOG_ERR, &locus,
- "%s",
- _("operation not applicable to strings"));
- errcnt++;
- return (MTX*)mtx;
- }
- break;
-
- case Integer:
- mtx->datatype = Integer;
- break;
- default:
- grad_insist_fail("unknown data type");
- }
- mtx->opcode = opcode;
- mtx->arg[0] = arg1;
- mtx->arg[1] = arg2;
- arg1->gen.uplink = arg2->gen.uplink = (MTX*)mtx;
- return (MTX*)mtx;
- }
- MTX *
- mtx_un(Uopcode opcode, MTX *arg)
- {
- UN_MTX *mtx = (UN_MTX*)mtx_alloc(Unary);
- mtx_append(mtx);
- if (arg->gen.datatype != Integer) {
- rw_coercion_warning(String, Integer, NULL);
- coerce(arg, Integer);
- }
- mtx->datatype = Integer;
- mtx->opcode = opcode;
- mtx->arg = arg;
- arg->gen.uplink = (MTX*)mtx;
- return (MTX*)mtx;
- }
- MTX *
- mtx_match(int negated, MTX *arg, COMP_REGEX *rx)
- {
- MATCH_MTX *mtx = (MATCH_MTX*)mtx_alloc(Match);
- mtx_append(mtx);
- if (arg->gen.datatype != String) {
- rw_coercion_warning(Integer, String, NULL);
- coerce(arg, String);
- }
- mtx->datatype = Integer;
- mtx->negated = negated;
- mtx->arg = arg;
- mtx->rx = rx;
- return (MTX*)mtx;
- }
- MTX *
- mtx_cond(MTX *cond, MTX *if_true, MTX *if_false)
- {
- COND_MTX *mtx = (COND_MTX*)mtx_alloc(Cond);
- mtx_append(mtx);
- mtx->expr = cond;
- mtx->if_true = if_true;
- mtx->if_false = if_false;
- return (MTX*)mtx;
- }
- MTX *
- mtx_coerce(grad_data_type_t type, MTX *arg)
- {
- if (type == arg->gen.datatype)
- return mtx_cur();
- return coerce(arg, type);
- }
- MTX *
- coerce(MTX *arg, grad_data_type_t type)
- {
- COERCE_MTX *mtx = (COERCE_MTX*)mtx_alloc(Coercion);
- mtx_insert(arg, (MTX*) mtx);
- mtx->datatype = type;
- mtx->arg = arg;
- return (MTX*)mtx;
- }
- MTX *
- mtx_call(FUNCTION *fun, MTX *args)
- {
- MTX *argp;
- CALL_MTX *call;
- PARAMETER *parmp;
- int argn;
-
- /*
- * Test the number and types of arguments. Insert reasonable
- * typecasts.
- */
- argn = 0;
- argp = args;
- parmp = fun->parm;
- while (argp && parmp) {
- if (argp->gen.datatype != parmp->datatype) {
- char buf[24];
- snprintf(buf, sizeof buf, _("(argument %d)"), argn);
- rw_coercion_warning(argp->gen.datatype,
- parmp->datatype, buf);
- coerce(argp, parmp->datatype);
- }
- argn++;
- argp = argp->gen.arglink;
- parmp = parmp->next;
- }
- /*
- * Note that the argument count mismatch is not an error!
- */
- if (argp) {
- grad_log_loc(GRAD_LOG_ERR, &locus,
- _("too many arguments in call to %s"),
- fun->name);
- errcnt++;
- } else if (parmp) {
- grad_log_loc(GRAD_LOG_ERR, &locus,
- _("too few arguments in call to %s"),
- fun->name);
- errcnt++;
- }
- call = (CALL_MTX*) mtx_alloc(Call);
- mtx_append((MTX*)call);
-
- call->datatype = fun->rettype;
- call->fun = fun;
- call->args = args;
- call->nargs = argn;
-
- return (MTX*) call;
- }
- MTX *
- mtx_builtin(builtin_t *bin, MTX *args)
- {
- MTX *argp;
- BTIN_MTX *call;
- int argn;
- char *parmp;
- grad_data_type_t type;
- /*
- * Test the number and types of arguments. Insert reasonable
- * typecasts.
- */
- argn = 0;
- argp = args;
- parmp = bin->parms;
-
- while (argp && parmp) {
- switch (parmp[0]) {
- case 'i':
- type = Integer;
- break;
- case 's':
- type = String;
- break;
- default:
- grad_insist_fail("malformed builtin");
- }
- if (argp->gen.datatype != type) {
- char buf[24];
- snprintf(buf, sizeof buf, _("(argument %d)"), argn);
- rw_coercion_warning(argp->gen.datatype, type, buf);
- coerce(argp, type);
- }
- argn++;
- argp = argp->gen.arglink;
- parmp++;
- }
- if (argp) {
- grad_log_loc(GRAD_LOG_ERR, &locus,
- _("too many arguments in call to %s"),
- bin->name);
- errcnt++;
- } else if (*parmp) {
- grad_log_loc(GRAD_LOG_ERR, &locus,
- _("too few arguments in call to %s"),
- bin->name);
- errcnt++;
- }
- call = (BTIN_MTX*) mtx_alloc(Builtin);
- mtx_append((MTX*)call);
-
- call->datatype = bin->rettype;
- call->fun = bin->handler;
- call->args = args;
- call->nargs = argn;
-
- return (MTX*) call;
- }
- /* ****************************************************************************
- * Code optimizer (rudimentary)
- */
- const char *
- datatype_str_nom(grad_data_type_t type)
- {
- switch (type) {
- case Undefined:
- return _("Undefined");
- case Integer:
- return _("integer");
- case String:
- return _("string");
- default:
- return _("UNKNOWN");
- }
- }
- const char *
- datatype_str_abl(grad_data_type_t type)
- {
- switch (type) {
- case Undefined:
- return _("from Undefined");
- case Integer:
- return _("from integer");
- case String:
- return _("from string");
- default:
- return _("from UNKNOWN");
- }
- }
- const char *
- datatype_str_acc(grad_data_type_t type)
- {
- switch (type) {
- case Undefined:
- return _("to Undefined");
- case Integer:
- return _("to integer");
- case String:
- return _("to string");
- default:
- return _("to UNKNOWN");
- }
- }
- FILE *
- debug_open_file()
- {
- FILE *fp;
- char *path;
-
- path = grad_mkfilename(grad_log_dir, "radius.mtx");
- if ((fp = fopen(path, "a")) == NULL) {
- grad_log(GRAD_LOG_ERR|GRAD_LOG_PERROR,
- _("can't open file `%s'"),
- path);
- }
- grad_free(path);
- return fp;
- }
- #if defined(MAINTAINER_MODE)
- static void debug_print_datum(FILE *fp, grad_data_type_t type, grad_datum_t *datum);
- static void debug_print_var(FILE *fp, VAR *var);
- static void debug_print_unary(FILE *fp, UN_MTX *mtx);
- static void debug_print_binary(FILE *fp, BIN_MTX *mtx);
- static void debug_print_mtxlist();
- static char *b_opstr[] = {
- "Eq",
- "Ne",
- "Lt",
- "Le",
- "Gt",
- "Ge",
- "&",
- "^",
- "|",
- "And",
- "Or",
- "Shl",
- "Shr",
- "Add",
- "Sub",
- "Mul",
- "Div",
- "Rem",
- };
- static char *u_opstr[] = {
- "Neg",
- "Not"
- };
- #define LINK(m) (m ? m->gen.id : 0)
- void
- debug_print_datum(FILE *fp, grad_data_type_t type, grad_datum_t *datum)
- {
- fprintf(fp, "%3.3s ", datatype_str_nom(type));
- switch (type) {
- case Integer:
- fprintf(fp, "%d", datum->ival);
- break;
-
- case String:
- fprintf(fp, "%s", datum->sval);
- break;
-
- default:
- grad_insist_fail("unknown data type");
- }
- }
- void
- debug_print_var(FILE *fp, VAR *var)
- {
- fprintf(fp, "%3.3s %s L:%d S:%d",
- datatype_str_nom(var->datatype),
- var->name,
- var->level,
- var->offset);
- if (var->constant) {
- fprintf(fp, "CONST ");
- debug_print_datum(fp, var->datatype, &var->datum);
- }
- }
- void
- debug_print_unary(FILE *fp, UN_MTX *mtx)
- {
- fprintf(fp, "OP:%s M:%d",
- u_opstr[mtx->opcode], LINK(mtx->arg));
- }
- void
- debug_print_binary(FILE *fp, BIN_MTX *mtx)
- {
- fprintf(fp, "OP:%s M1:%d M2:%d",
- b_opstr[mtx->opcode],
- LINK(mtx->arg[0]),
- LINK(mtx->arg[1]));
- }
- void
- debug_print_mtxlist(char *s)
- {
- FILE *fp;
- MTX *mtx, *tmp;
-
- if ((fp = debug_open_file()) == NULL)
- return;
- #define CASE(c) case c: fprintf(fp, "%-10.10s", #c);
- fprintf(fp, "%s\n", s);
- for (mtx = mtx_first; mtx; mtx = mtx->gen.next) {
- fprintf(fp, "%4d: %4d %4d ",
- mtx->gen.id,
- LINK(mtx->gen.prev),
- LINK(mtx->gen.next));
- switch (mtx->gen.type) {
- CASE (Generic)
- break;
- CASE (Nop)
- break;
- CASE (Enter)
- fprintf(fp, "%3.3s %d",
- "",
- mtx->frame.stacksize);
- break;
- CASE (Leave)
- fprintf(fp, "%3.3s %d",
- "",
- mtx->frame.stacksize);
- break;
- CASE (Stop)
- break;
- CASE (Constant)
- debug_print_datum(fp, mtx->cnst.datatype,
- &mtx->cnst.datum);
- break;
- CASE (Matchref)
- fprintf(fp, "%3.3s %d",
- datatype_str_nom(String),
- mtx->ref.num);
- break;
- CASE (Variable)
- debug_print_var(fp, mtx->var.var);
- break;
- CASE (Unary)
- fprintf(fp, "%3.3s ", datatype_str_nom(mtx->gen.datatype));
- debug_print_unary(fp, &mtx->un);
- break;
- CASE (Binary)
- fprintf(fp, "%3.3s ", datatype_str_nom(mtx->gen.datatype));
- debug_print_binary(fp, &mtx->bin);
- break;
- CASE (Cond)
- fprintf(fp, "%3.3s ", "");
- fprintf(fp, "C:%4d T:%4d F:%4d",
- LINK(mtx->cond.expr),
- LINK(mtx->cond.if_true),
- LINK(mtx->cond.if_false));
- break;
- CASE (Asgn)
- fprintf(fp, "%3.3s ",
- datatype_str_nom(mtx->gen.datatype));
- fprintf(fp, "V:%s,%d,%d M:%4d",
- mtx->asgn.lval->name,
- mtx->asgn.lval->level,
- mtx->asgn.lval->offset,
- LINK(mtx->asgn.arg));
- break;
- CASE (Match)
- fprintf(fp, " N:%1d M:%4d RX:%p",
- mtx->match.negated,
- LINK(mtx->match.arg),
- mtx->match.rx);
- break;
- CASE (Coercion)
- fprintf(fp, "%3.3s M:%4d",
- datatype_str_nom(mtx->coerce.datatype),
- LINK(mtx->coerce.arg));
- break;
- CASE (Return)
- fprintf(fp, "%3.3s M:%4d",
- datatype_str_nom(mtx->ret.expr->gen.datatype),
- LINK(mtx->ret.expr));
- break;
- CASE (Jump)
- fprintf(fp, "%3.3s M:%4d",
- "",
- LINK(mtx->jump.dest));
- break;
- CASE (Branch)
- fprintf(fp, "%3.3s M:%4d",
- mtx->branch.cond ? "NE" : "EQ",
- LINK(mtx->branch.dest));
- break;
- CASE (Call)
- fprintf(fp, "%3.3s F:%s, A:%d:",
- datatype_str_nom(mtx->call.datatype),
- mtx->call.fun->name,
- mtx->call.fun->nparm);
- for (tmp = mtx->call.args; tmp; tmp = tmp->gen.arglink)
- fprintf(fp, "%d,", tmp->gen.id);
- break;
- CASE(Builtin)
- fprintf(fp, "%3.3s F:%p, A:%d:",
- datatype_str_nom(mtx->btin.datatype),
- mtx->btin.fun,
- mtx->btin.nargs);
- for (tmp = mtx->btin.args; tmp; tmp = tmp->gen.arglink)
- fprintf(fp, "%d,", tmp->gen.id);
- break;
- CASE (Pop)
- break;
- CASE (Pusha)
- break;
- CASE (Popa)
- break;
-
- CASE (Attr)
- fprintf(fp, "%3.3s A:%d I:%d",
- datatype_str_nom(mtx->gen.datatype),
- mtx->attr.attrno,
- mtx->attr.index ? mtx->attr.index->gen.id : 0);
- break;
- CASE (Attr_check)
- fprintf(fp, "%3.3s A:%d I:%d",
- datatype_str_nom(mtx->gen.datatype),
- mtx->attr.attrno,
- mtx->attr.index ? mtx->attr.index->gen.id : 0);
- break;
-
- CASE (Attr_asgn)
- fprintf(fp, "%3.3s A:%d I:%d M:%d",
- datatype_str_nom(mtx->gen.datatype),
- mtx->attr.attrno,
- mtx->attr.index ? mtx->attr.index->gen.id : 0,
- LINK(mtx->attr.rval));
- break;
-
- CASE (Attr_delete)
- fprintf(fp, "%3.3s A:%d I:%d",
- datatype_str_nom(mtx->gen.datatype),
- mtx->attr.attrno,
- mtx->attr.index ? mtx->attr.index->gen.id : 0);
- break;
-
- default:
- fprintf(fp, "UNKNOWN: %d", mtx->gen.type);
- }
- fprintf(fp, "\n");
- }
-
- fclose(fp);
- }
- void
- debug_print_function()
- {
- FILE *fp;
- PARAMETER *parm;
- int n;
-
- if ((fp = debug_open_file()) == NULL)
- return;
- fprintf(fp, "FUNCTION: %s\n", function->name);
- fprintf(fp, "RETURNS : %s\n", datatype_str_nom(function->rettype));
- fprintf(fp, "NPARMS : %d\n", function->nparm);
- fprintf(fp, "PARMS :\n");
- for (parm = function->parm, n = 0; parm; parm = parm->next, n++)
- fprintf(fp, " %4d: %s at %4d\n",
- n, datatype_str_nom(parm->datatype),
- parm->offset);
-
- fclose(fp);
- }
- #endif /* MAINTAINER_MODE */
-
- #if defined(MAINTAINER_MODE)
- # define DEBUG_MTX(c) if (GRAD_DEBUG_LEVEL(30)) debug_print_mtxlist(c);
- # define DEBUG_FUN() if (GRAD_DEBUG_LEVEL(25)) debug_print_function();
- #else
- # define DEBUG_MTX(c)
- # define DEBUG_FUN()
- #endif
- static void pass1();
- static int pass2_unary(MTX *mtx);
- static int pass2_binary(MTX *mtx);
- void
- pass1()
- {
- MTX *mtx;
- MTX *end;
-
- /*
- * Create an entry matrix
- */
- mtx = mtx_alloc(Enter);
- rw_list_insert(&mtx_first, &mtx_last, mtx_first, mtx, 1);
- mtx->frame.stacksize = function->stack_alloc;
-
- /*
- * Provide a default return statement if necessary
- */
- if (mtx_last->gen.type != Return) {
- grad_value_t val;
- grad_log_loc(GRAD_LOG_WARN, &mtx_last->gen.loc,
- _("missing return statement"));
- val.type = function->rettype;
- switch (function->rettype) {
- case Integer:
- val.datum.ival = 0;
- break;
-
- case String:
- val.datum.sval.data = "";
- val.datum.sval.size = 0;
- break;
- default:
- grad_insist_fail("Unknown data type");
- }
- mtx_const(&val);
- mtx_frame(Leave, function->stack_alloc);
- } else {
- mtx_last->gen.type = Leave;
- mtx_last->frame.stacksize = function->stack_alloc;
- }
- /*
- * Insert a no-op matrix before the `leave' one
- */
- end = mtx_alloc(Nop);
- rw_list_insert(&mtx_first, &mtx_last, mtx_last, end, 1);
-
- for (mtx = mtx_first; mtx; mtx = mtx->gen.next) {
- if (mtx->gen.type == Return) {
- if (mtx->ret.expr->gen.datatype != function->rettype) {
- rw_coercion_warning(
- mtx->ret.expr->gen.datatype,
- function->rettype, NULL);
- coerce(mtx->ret.expr, function->rettype);
- }
- mtx->gen.type = Jump;
- mtx->jump.dest = end;
- }
- }
- }
-
- /*
- * Second pass: elimination of constant sub-expressions
- */
- /*
- * Perform immediate unary calculations
- */
- int
- pass2_unary(MTX *mtx)
- {
- MTX *arg = mtx->un.arg;
-
- switch (mtx->un.opcode) {
- case Not:
- arg->cnst.datum.ival = !arg->cnst.datum.ival;
- break;
-
- case Neg:
- arg->cnst.datum.ival = -arg->cnst.datum.ival;
- break;
- default:
- grad_insist_fail("Unexpected opcode");
- }
- mtx->gen.type = Constant;
- mtx->cnst.datum = arg->cnst.datum;
- mtx_remove(arg);
- return 0;
- }
- /*
- * Perform immediate binary computations
- */
- int
- pass2_binary(MTX *mtx)
- {
- MTX *arg0 = mtx->bin.arg[0];
- MTX *arg1 = mtx->bin.arg[1];
- grad_datum_t dat;
-
- switch (mtx->bin.opcode) {
- case Eq:
- dat.ival = arg0->cnst.datum.ival == arg1->cnst.datum.ival;
- break;
-
- case Ne:
- dat.ival = arg0->cnst.datum.ival != arg1->cnst.datum.ival;
- break;
-
- case Lt:
- dat.ival = arg0->cnst.datum.ival < arg1->cnst.datum.ival;
- break;
-
- case Le:
- dat.ival = arg0->cnst.datum.ival <= arg1->cnst.datum.ival;
- break;
-
- case Gt:
- dat.ival = arg0->cnst.datum.ival > arg1->cnst.datum.ival;
- break;
-
- case Ge:
- dat.ival = arg0->cnst.datum.ival >= arg1->cnst.datum.ival;
- break;
-
- case BAnd:
- dat.ival = arg0->cnst.datum.ival & arg1->cnst.datum.ival;
- break;
-
- case BOr:
- dat.ival = arg0->cnst.datum.ival | arg1->cnst.datum.ival;
- break;
-
- case BXor:
- dat.ival = arg0->cnst.datum.ival ^ arg1->cnst.datum.ival;
- break;
-
- case And:
- dat.ival = arg0->cnst.datum.ival && arg1->cnst.datum.ival;
- break;
-
- case Or:
- dat.ival = arg0->cnst.datum.ival || arg1->cnst.datum.ival;
- break;
-
- case Shl:
- dat.ival = arg0->cnst.datum.ival << arg1->cnst.datum.ival;
- break;
-
- case Shr:
- dat.ival = arg0->cnst.datum.ival >> arg1->cnst.datum.ival;
- break;
-
- case Add:
- dat.ival = arg0->cnst.datum.ival + arg1->cnst.datum.ival;
- break;
-
- case Sub:
- dat.ival = arg0->cnst.datum.ival - arg1->cnst.datum.ival;
- break;
-
- case Mul:
- dat.ival = arg0->cnst.datum.ival * arg1->cnst.datum.ival;
- break;
-
- case Div:
- if (arg1->cnst.datum.ival == 0) {
- grad_log_loc(GRAD_LOG_ERR, &arg1->cnst.loc,
- _("divide by zero"));
- errcnt++;
- } else
- dat.ival =
- arg0->cnst.datum.ival / arg1->cnst.datum.ival;
- break;
-
- case Rem:
- if (arg1->cnst.datum.ival == 0) {
- grad_log_loc(GRAD_LOG_ERR, &arg1->cnst.loc,
- _("divide by zero"));
- errcnt++;
- } else
- dat.ival =
- arg0->cnst.datum.ival % arg1->cnst.datum.ival;
- break;
- default:
- grad_insist_fail("Unexpected opcode");
- }
- mtx->gen.type = Constant;
- mtx->cnst.datum = dat;
- mtx_remove(arg0);
- mtx_remove(arg1);
- return 0;
- }
- MTX *
- mtx_branch(int cond, MTX *target)
- {
- MTX *nop = mtx_alloc(Nop);
- MTX *mtx = mtx_alloc(Branch);
- mtx_insert(target, nop);
- mtx->branch.cond = cond;
- mtx->branch.dest = nop;
- return mtx;
- }
- void
- mtx_bool(MTX *mtx)
- {
- MTX *j_mtx, *p, *p1;
- /* Insert after first operand:
- popa
- pusha
- pusha ;; Duplicate tos value
- j?e L10
- popa ;; Pop up the unneded value */
- p = mtx_alloc(Popa);
- mtx_insert(mtx->bin.arg[0], p);
- p1 = mtx_alloc(Pusha);
- mtx_insert(p, p1);
- p = mtx_alloc(Pusha);
- mtx_insert(p1, p);
- j_mtx = mtx_branch(mtx->bin.opcode == Or, mtx);
- mtx_insert(p, j_mtx);
- p1 = mtx_alloc(Popa);
- mtx_insert(j_mtx, p1);
- /* Remove the op matrix
- Note that the mtx->cond.expr is not correct after this
- operation, but this does not affect the functionality */
- mtx_remove(mtx);
- }
- /*
- * Second optimization pass: immediate computations
- */
- int
- pass2()
- {
- MTX *mtx, *next;
- int optcnt;
- int errcnt = 0;
-
- do {
- optcnt = 0;
- mtx = mtx_first;
- while (mtx) {
- next = mtx->gen.next;
- switch (mtx->gen.type) {
- case Unary:
- if (mtx->un.arg->gen.type != Constant)
- break;
- if (pass2_unary(mtx))
- errcnt++;
- else
- optcnt++;
- break;
-
- case Binary:
- if (mtx->bin.arg[0]->gen.type == Constant
- && mtx->bin.arg[1]->gen.type == Constant) {
- switch (mtx->bin.datatype) {
- case Integer:
- if (pass2_binary(mtx))
- errcnt++;
- else
- optcnt++;
- break;
-
- case String:
- /*NO STRING OPS SO FAR */;
- break;
- default:
- grad_insist_fail("Unknown data type");
- }
- } else if (mtx->bin.opcode == And
- || mtx->bin.opcode == Or) {
- mtx_bool(mtx);
- }
- break;
- /*FIXME: ADD `if (1)'/`if 0' evaluation */
- case Jump:
- if (mtx->jump.dest == mtx->jump.next)
- mtx_remove(mtx);
- break;
- case Attr:
- case Attr_asgn:
- case Attr_check:
- case Attr_delete:
- /*FIXME: the rw_attr.0 functions should
- expect an immediate value after the
- attribute number */
- break;
- default:
- break;
- }
- mtx = next;
- }
- } while (errcnt == 0 && optcnt > 0);
- return errcnt;
- }
- int
- optimize()
- {
- DEBUG_FUN();
- DEBUG_MTX("on entry to optimize");
- pass1();
- DEBUG_MTX("after first pass");
- if (pass2())
- return -1;
- DEBUG_MTX("after second pass (immediate computations)");
- return 0;
- }
- /* ****************************************************************************
- * Code generator
- */
- static INSTR *rw_code; /* Code segment */
- static pctr_t rw_pc; /* PC when compiling the code */
- static size_t rw_codesize; /* Length of code segment */
- void
- code_check()
- {
- if (rw_code == NULL) {
- rw_codesize = 4096;
- rw_code = grad_emalloc(rw_codesize * sizeof(rw_code[0]));
- }
- }
- void
- code_init()
- {
- code_check();
- /* code cell #0 is the default return address */
- rw_code[0] = 0;
- rw_pc = 1;
- }
- #if defined(MAINTAINER_MODE)
- void
- debug_dump_code()
- {
- FILE *fp;
- pctr_t pc;
- int i;
-
- if ((fp = debug_open_file()) == NULL)
- return;
- fprintf(fp, "Code size: %d\n", rw_codesize);
- fprintf(fp, "Code dump:\n");
- pc = 0;
- do {
- fprintf(fp, "%4d:", pc);
- for (i = 0; i < 8 && pc < rw_codesize; i++, pc++)
- fprintf(fp, " %8x", (u_int) rw_code[pc]);
- fprintf(fp, "\n");
- } while (pc < rw_codesize);
-
- fclose(fp);
- }
- #endif
- /*
- * Runtime function prototypes
- */
- static int pushn(RWSTYPE n);
- static int cpopn(RWSTYPE *np);
- static RWSTYPE popn();
- static void checkpop(int cnt);
- static void pushref(char *str, int from, int to);
- static RWSTYPE *heap_reserve(int size);
- static void pushs(RWSTYPE *sptr, size_t size, int len);
- static void pushstr(const char *str, int len);
- static void rw_pushn();
- static void rw_pushs();
- static void rw_pushref();
- static void rw_pushv();
- static void rw_i2s();
- static void rw_s2i();
- static void rw_eq();
- static void rw_ne();
- static void rw_lt();
- static void rw_le();
- static void rw_gt();
- static void rw_ge();
- static void rw_eqs();
- static void rw_nes();
- static void rw_lts();
- static void rw_les();
- static void rw_gts();
- static void rw_ges();
- static void rw_b_xor();
- static void rw_b_and();
- static void rw_b_or();
- static void rw_shl();
- static void rw_shr();
- static void rw_add();
- static void rw_sub();
- static void rw_mul();
- static void rw_div();
- static void rw_rem();
- static void rw_not();
- static void rw_neg();
- static void rw_asgn();
- static void rw_enter();
- static void rw_leave();
- static void rw_match();
- static void rw_jmp();
- static void rw_jne();
- static void rw_je();
- static void rw_adds();
- static void rw_adjstk();
- static void rw_popn();
- static void rw_pusha();
- static void rw_popa();
- static void rw_call();
- static void rw_builtin();
- static void rw_attrs();
- static void rw_attrs0();
- static void rw_attrn();
- static void rw_attrn0();
- static void rw_attrcheck();
- static void rw_attrcheck0();
- static void rw_attrasgn();
- static void rw_attrasgn0();
- static void rw_attr_delete();
- static void rw_attr_delete0();
- INSTR bin_codetab[] = {
- rw_eq,
- rw_ne,
- rw_lt,
- rw_le,
- rw_gt,
- rw_ge,
- rw_b_and,
- rw_b_xor,
- rw_b_or,
- NULL,
- NULL,
- rw_shl,
- rw_shr,
- rw_add,
- rw_sub,
- rw_mul,
- rw_div,
- rw_rem,
- };
- INSTR bin_string_codetab[] = {
- rw_eqs,
- rw_nes,
- rw_lts,
- rw_les,
- rw_gts,
- rw_ges,
- NULL,
- NULL,
- NULL,
- NULL,
- NULL,
- NULL,
- NULL,
- rw_adds,
- NULL,
- NULL,
- NULL,
- NULL
- };
- INSTR coerce_tab[Max_datatype][Max_datatype] = {
- /* Undefined Integer String */
- /* Undefined */ { NULL, NULL, NULL },
- /* Integer */ { NULL, NULL, rw_i2s },
- /* String */ { NULL, rw_s2i, NULL },
- };
- static void check_codesize(int delta);
- static int code(INSTR instr);
- static int data(int val);
- static int data_str(char *ptr);
- static void add_target(NOP_MTX *mtx, pctr_t pc);
- void
- add_target(NOP_MTX *mtx, pctr_t pc)
- {
- TGT_MTX *tgt = (TGT_MTX *)mtx_alloc(Target);
- tgt->next = (MTX*)mtx->tgt;
- mtx->tgt = tgt;
- tgt->pc = pc;
- }
- void
- fixup_target(NOP_MTX *mtx, pctr_t pc)
- {
- TGT_MTX *tgt;
-
- for (tgt = (TGT_MTX*)mtx->tgt; tgt; tgt = (TGT_MTX*)tgt->next)
- rw_code[tgt->pc] = (INSTR)pc;
- mtx->tgt = NULL;
- }
- pctr_t
- codegen()
- {
- MTX *mtx;
- function->entry = rw_pc;
- for (mtx = mtx_first; mtx; mtx = mtx->gen.next) {
- switch (mtx->gen.type) {
- case Generic:
- case Return:
- default:
- grad_log(GRAD_LOG_CRIT,
- "INTERNAL ERROR: codegen stumbled accross generic matrix!");
- errcnt++;
- return 0;
- case Nop:
- /* Fix-up the references */
- fixup_target(&mtx->nop, rw_pc);
- mtx->nop.pc = rw_pc;
- break;
- case Stop:
- break;
- case Enter:
- code(rw_enter);
- data(mtx->frame.stacksize);
- break;
- case Leave:
- code(rw_leave);
- break;
- case Constant:
- switch (mtx->cnst.datatype) {
- case Integer:
- code(rw_pushn);
- data(mtx->cnst.datum.ival);
- break;
-
- case String:
- code(rw_pushs);
- data_str(mtx->cnst.datum.sval.data);
- break;
- default:
- grad_insist_fail("Unknown data type");
- }
- break;
- case Matchref:
- code(rw_pushref);
- data(mtx->ref.num);
- break;
- case Variable:
- /* Variable dereference.
- */
- code(rw_pushv);
- data(mtx->var.var->offset);
- break;
- case Unary:
- switch (mtx->un.opcode) {
- case Not:
- code(rw_not);
- break;
-
- case Neg:
- code(rw_neg);
- break;
- default:
- grad_insist_fail("Unexpected opcode");
- }
- break;
- case Binary:
- if (mtx->bin.arg[0]->gen.datatype == String)
- code(bin_string_codetab[mtx->bin.opcode]);
- else
- code(bin_codetab[mtx->bin.opcode]);
- break;
- case Cond:
- /*FIXME: this needs optimization */
- code(rw_jne);
- add_target(&mtx->cond.if_true->nop, rw_pc);
- code(NULL);
- if (mtx->cond.if_false) {
- code(rw_jmp);
- add_target(&mtx->cond.if_false->nop, rw_pc);
- code(NULL);
- }
- break;
-
- case Asgn:
- code(rw_asgn);
- data(mtx->asgn.lval->offset);
- break;
-
- case Match:
- code(rw_match);
- code((INSTR)mtx->match.rx);
- if (mtx->match.negated)
- code(rw_not);
- break;
-
- case Coercion:
- code(coerce_tab[mtx->coerce.arg->gen.datatype][mtx->coerce.datatype]);
- break;
-
- case Jump:
- code(rw_jmp);
- add_target(&mtx->jump.dest->nop, rw_pc);
- code(NULL);
- break;
- case Branch:
- code(mtx->branch.cond ? rw_jne : rw_je);
- add_target(&mtx->branch.dest->nop, rw_pc);
- code(NULL);
- break;
-
- case Call:
- code(rw_call);
- code((INSTR) mtx->call.fun->entry);
- code(rw_adjstk);
- data(mtx->call.nargs);
- break;
- case Builtin:
- code(rw_builtin);
- code(mtx->btin.fun);
- code(rw_adjstk);
- data(mtx->btin.nargs);
- break;
- case Pop:
- code(rw_popn);
- break;
- case Popa:
- code(rw_popa);
- break;
-
- case Pusha:
- code(rw_pusha);
- break;
-
- case Attr:
- switch (mtx->attr.datatype) {
- case Integer:
- if (mtx->attr.index)
- code(rw_attrn);
- else
- code(rw_attrn0);
- break;
-
- case String:
- if (mtx->attr.index)
- code(rw_attrs);
- else
- code(rw_attrs0);
- break;
- default:
- grad_insist_fail("Unknown data type");
- }
- data(mtx->attr.attrno);
- break;
- case Attr_check:
- if (mtx->attr.index)
- code(rw_attrcheck);
- else
- code(rw_attrcheck0);
- data(mtx->attr.attrno);
- break;
-
- case Attr_asgn:
- if (mtx->attr.index)
- code(rw_attrasgn);
- else
- code(rw_attrasgn0);
- data(mtx->attr.attrno);
- break;
-
- case Attr_delete:
- if (mtx->attr.index)
- code(rw_attr_delete);
- else
- code(rw_attr_delete0);
- data(mtx->attr.attrno);
- break;
- }
- }
- /*
- * Second pass: fixup backward references
- */
- for (mtx = mtx_first; mtx; mtx = mtx->gen.next) {
- if (mtx->gen.type == Nop)
- fixup_target(&mtx->nop, mtx->nop.pc);
- }
-
- #if defined(MAINTAINER_MODE)
- if (GRAD_DEBUG_LEVEL(25)) {
- FILE *fp = debug_open_file();
- fprintf(fp, "entry: %d, size %d\n",
- function->entry, rw_pc - function->entry);
- fclose(fp);
- }
- #endif
- return function->entry;
- }
- void
- check_codesize(int delta)
- {
- if (rw_pc + delta >= rw_codesize) {
- INSTR *p = grad_emalloc((rw_codesize + 4096) * sizeof(rw_code[0]));
- memcpy(p, rw_code, rw_codesize * sizeof(rw_code[0]));
- grad_free(rw_code);
- rw_code = p;
- rw_codesize += 4096;
- }
- }
- int
- code(INSTR instr)
- {
- check_codesize(1);
- rw_code[rw_pc] = instr;
- return rw_pc++;
- }
- int
- data(int val)
- {
- return code((INSTR)(RWSTYPE)val);
- }
- int
- data_str(char *ptr)
- {
- int len = strlen(ptr) + 1;
- RWSTYPE delta = (len + sizeof(rw_code[0])) / sizeof(rw_code[0]);
-
- check_codesize(delta+1);
- rw_code[rw_pc++] = (INSTR)delta;
- memcpy(rw_code + rw_pc, ptr, len);
- rw_pc += delta;
- return rw_pc;
- }
-
- /* ****************************************************************************
- * Regular expressions
- */
- COMP_REGEX *
- rx_alloc(regex_t *regex, int nmatch)
- {
- COMP_REGEX *rx;
- rx = grad_emalloc(sizeof(*rx));
- rx->regex = *regex;
- rx->nmatch = nmatch;
- rw_list_insert(&function->rx_list, NULL, function->rx_list, rx, 1);
- return rx;
- }
- void
- rx_free(COMP_REGEX *rx)
- {
- COMP_REGEX *next;
- while (rx) {
- next = rx->next;
- regfree(&rx->regex);
- grad_free(rx);
- rx = next;
- }
- }
- COMP_REGEX *
- compile_regexp(char *str)
- {
- char *p;
- regex_t regex;
- int nmatch;
-
- int rc = regcomp(®ex, str, regcomp_flags);
- if (rc) {
- char errbuf[512];
- regerror(rc, ®ex, errbuf, sizeof(errbuf));
- grad_log_loc(GRAD_LOG_ERR, &locus,
- _("regexp error: %s"),
- errbuf);
- return NULL;
- }
- /* count the number of matches */
- nmatch = 0;
- for (p = str; *p; ) {
- if (*p == '\\')
- if (p[1] == '(') {
- nmatch++;
- p += 2;
- continue;
- }
- p++;
- }
-
- return rx_alloc(®ex, nmatch);
- }
- void
- function_delete()
- {
- if (function) {
- grad_symtab_delete(rewrite_tab, (grad_symbol_t*)function);
- function_cleanup();
- }
- }
- void
- function_cleanup()
- {
- function = NULL;
- }
- /* ****************************************************************************
- * Runtime functions
- */
- /*
- * Push a number on stack
- */
- int
- pushn(RWSTYPE n)
- {
- if (mach.st >= mach.ht) {
- /*FIXME: gc();*/
- GRAD_DEBUG2(1, "st=%d, ht=%d", mach.st, mach.ht);
- rw_error(_("out of pushdown space"));
- }
- mach.stack[mach.st++] = n;
- return 0;
- }
- /*
- * Push a string on stack
- */
- void
- pushs(RWSTYPE *sptr, size_t size, int len)
- {
- if (mach.ht - len - 1 <= mach.st) {
- /* Heap overrun: */
- /*gc(); */
- rw_error(_("heap overrun"));
- }
- while (len)
- mach.stack[mach.ht--] = sptr[--len];
- mach.stack[mach.ht--] = size;
- pushn((RWSTYPE) (mach.stack + mach.ht + 1));
- }
- void
- pushstr(const char *str, int len)
- {
- RWSTYPE *p = heap_reserve(sizeof(RWSTYPE) + len + 1);
- char *s = (char*)(p + 1);
- memcpy(s, str, len);
- s[len] = 0;
- p[0] = len;
- pushn((RWSTYPE)p);
- }
- #define B2RW(s) (s + sizeof(mach.stack[0]) - 1) / sizeof(mach.stack[0])
- RWSTYPE *
- heap_reserve(int size)
- {
- size_t words = B2RW(size);
- if (mach.ht - words <= mach.st) {
- /* Heap overrun: */
- gc();
- if (mach.ht - words <= mach.st)
- rw_error(_("heap overrun"));
- }
- mach.ht -= words;
- return mach.stack + mach.ht--;
- }
- /* Temporary space functions */
- char *
- temp_space_create()
- {
- return (char*)(mach.stack + mach.st);
- }
- size_t
- temp_space_size()
- {
- return (mach.ht - mach.st)*sizeof(mach.stack[0]);
- }
- void
- temp_space_copy(char **baseptr, char *text, size_t size)
- {
- size_t len = (size + sizeof(mach.stack[0])) / sizeof(mach.stack[0]);
- if (*baseptr + len >= (char*)(mach.stack + mach.ht))
- rw_error(_("out of heap space"));
- memcpy(*baseptr, text, size);
- *baseptr += size;
- }
- RWSTYPE *
- temp_space_fix(char *end)
- {
- size_t len, size;
- char *base = (char*)(mach.stack + mach.st);
- temp_space_copy(&end, "", 0);
- size = end - base;
- len = B2RW(size);
- mach.ht -= len;
- memmove(mach.stack + mach.ht, base, size);
- mach.stack[--mach.ht] = strlen(base);
- return mach.stack + mach.ht--;
- }
- /*
- * Pop number from stack and store into NP.
- */
- int
- cpopn(RWSTYPE *np)
- {
- if (mach.st <= 0) {
- rw_error(_("out of popup"));
- }
- *np = mach.stack[--mach.st];
- return 0;
- }
- /*
- * Pop the number from stack without error checking. checkpop() function
- * should be called before calling this one.
- */
- RWSTYPE
- popn()
- {
- return mach.stack[--mach.st];
- }
- void
- mem2string(grad_string_t *p, RWSTYPE *loc)
- {
- p->size = loc[0];
- p->data = (unsigned char*) (loc + 1);
- }
- void
- poparr(grad_string_t *p)
- {
- mem2string(p, (RWSTYPE*) popn());
- }
- RWSTYPE
- tos()
- {
- return mach.stack[mach.st-1];
- }
- /*
- * Check if the stack contains at list CNT elements.
- */
- void
- checkpop(int cnt)
- {
- if (mach.st < cnt)
- rw_error(_("out of popup"));
- }
-
- /*
- * Push a backreference value on stack.
- * Arguments: str -- input string
- * from -- start of reference in string
- * to -- end of reference in string
- */
- void
- pushref(char *str, int from, int to)
- {
- pushstr(str + from, to - from);
- }
- /*
- * Create a stack frame and enter the function
- */
- void
- enter(int n)
- {
- pushn(mach.sb);
- mach.sb = mach.st;
- mach.st += n;
- }
- /*
- * Destroy the stack frame and leave the function
- */
- void
- leave()
- {
- /* Save return value */
- mach.rA = popn();
- /* Restore stack frame */
- mach.st = mach.sb;
- mach.sb = popn();
- mach.pc = (pctr_t) popn();
- }
- RWSTYPE
- getarg(int num)
- {
- return mach.stack[mach.sb - (STACK_BASE + num)];
- }
- /* ****************************************************************************
- * Instructions
- */
- static int
- rw_error(const char *msg)
- {
- grad_log(GRAD_LOG_ERR,
- "%s: %s",
- _("rewrite runtime error"), msg);
- longjmp(mach.jmp, 1);
- /*NOTREACHED*/
- }
-
- static int
- rw_error_free(char *msg)
- {
- grad_log(GRAD_LOG_ERR,
- "%s: %s",
- _("rewrite runtime error"), msg);
- free(msg);
- longjmp(mach.jmp, 1);
- /*NOTREACHED*/
- }
-
- void
- rw_call()
- {
- pctr_t pc = (pctr_t) rw_code[mach.pc++];
- pushn(mach.pc); /* save return address */
- mach.pc = pc;
- }
- void
- rw_adjstk()
- {
- int delta = (int) rw_code[mach.pc++];
- mach.st -= delta;
- pushn(mach.rA); /* Push the return back on stack */
- }
- void
- rw_enter()
- {
- /*FIXME: runtime checking */
- int n = (int) rw_code[mach.pc++];
- enter(n);
- }
- void
- rw_leave()
- {
- leave();
- }
- /*
- * Push a number on stack
- */
- void
- rw_pushn()
- {
- RWSTYPE n = (RWSTYPE) rw_code[mach.pc++];
- pushn(n);
- }
- /*
- * Push a reference value on stack
- */
- void
- rw_pushref()
- {
- int i = (int) rw_code[mach.pc++];
- pushref(mach.sA, mach.pmatch[i].rm_so, mach.pmatch[i].rm_eo);
- }
- /*
- * Push a variable on stack
- */
- void
- rw_pushv()
- {
- stkoff_t n = (stkoff_t) rw_code[mach.pc++];
- pushn(mach.stack[mach.sb + n]);
- }
- void
- rw_pushs()
- {
- int len = (int) rw_code[mach.pc++];
- RWSTYPE *sptr = (RWSTYPE*) (rw_code + mach.pc);
- mach.pc += len;
- pushs(sptr, strlen((char*)sptr), len);
- }
- /*
- * Assign a value to a variable
- */
- void
- rw_asgn()
- {
- stkoff_t off = (stkoff_t) rw_code[mach.pc++];
- RWSTYPE n;
- cpopn(&n);
-
- mach.stack[mach.sb + off] = n;
- pushn(n);
- }
- void
- assert_request_presence()
- {
- if (!mach.req)
- rw_error(_("no request supplied"));
- }
- /* Check if the A/V pair is supplied in the request
- */
- void
- rw_attrcheck0()
- {
- int attr = (int) rw_code[mach.pc++];
- pushn(grad_avl_find(AVPLIST(&mach), attr) != NULL);
- }
- void
- rw_attrcheck()
- {
- int attr = (int) rw_code[mach.pc++];
- RWSTYPE index;
-
- cpopn(&index);
- pushn(grad_avl_find_n(AVPLIST(&mach), attr, index) != NULL);
- }
- /*
- * Assign a value to an A/V pair
- */
- void
- attrasgn_internal(int attr, grad_avp_t *pair, RWSTYPE val)
- {
- grad_string_t str;
-
- assert_request_presence();
- if (!pair) {
- pair = grad_avp_create(attr);
- if (!pair)
- rw_error(_("can't create A/V pair"));
- grad_avl_add_pair(&mach.req->avlist, pair);
- }
-
- switch (pair->type) {
- case GRAD_TYPE_STRING:
- case GRAD_TYPE_DATE:
- mem2string(&str, (RWSTYPE*)val);
- grad_free(pair->avp_strvalue);
- pair->avp_strvalue = grad_malloc(str.size+1);
- memcpy(pair->avp_strvalue, str.data, str.size);
- pair->avp_strvalue[str.size] = 0;
- pair->avp_strlength = str.size;
- break;
-
- case GRAD_TYPE_INTEGER:
- case GRAD_TYPE_IPADDR:
- pair->avp_lvalue = val;
- break;
- }
-
- pushn(val);
- }
- void
- rw_attrasgn0()
- {
- int attr = (int) rw_code[mach.pc++];
- RWSTYPE val;
-
- cpopn(&val);
- attrasgn_internal(attr, grad_avl_find(AVPLIST(&mach), attr), val);
- }
- void
- rw_attrasgn()
- {
- int attr = (int) rw_code[mach.pc++];
- RWSTYPE val;
- RWSTYPE index;
-
- cpopn(&val);
- cpopn(&index);
- attrasgn_internal(attr, grad_avl_find_n(AVPLIST(&mach), attr, index),
- val);
- }
- void
- rw_attrs0()
- {
- int attr = (int) rw_code[mach.pc++];
- grad_avp_t *pair;
-
- if ((pair = grad_avl_find(AVPLIST(&mach), attr)) == NULL)
- pushstr("", 0);
- else if (pair->prop & GRAD_AP_ENCRYPT) {
- char string[GRAD_STRING_LENGTH+1];
- int len;
- req_decrypt_password(string, mach.req, pair);
- len = strlen(string);
- pushstr(string, len);
- } else
- pushstr(pair->avp_strvalue, pair->avp_strlength);
- }
- void
- rw_attrn0()
- {
- int attr = (int) rw_code[mach.pc++];
- grad_avp_t *pair;
- if ((pair = grad_avl_find(AVPLIST(&mach), attr)) == NULL)
- pushn(0);
- else
- pushn(pair->avp_lvalue);
- }
- void
- rw_attrs()
- {
- int attr = (int) rw_code[mach.pc++];
- grad_avp_t *pair;
- RWSTYPE index;
- cpopn(&index);
- if ((pair = grad_avl_find_n(AVPLIST(&mach), attr, index)) == NULL)
- pushstr("", 0);
- else
- pushstr(pair->avp_strvalue, pair->avp_strlength);
- }
- void
- rw_attrn()
- {
- int attr = (int) rw_code[mach.pc++];
- grad_avp_t *pair;
- RWSTYPE index;
- cpopn(&index);
- if ((pair = grad_avl_find_n(AVPLIST(&mach), attr, index)) == NULL)
- pushn(0);
- else
- pushn(pair->avp_lvalue);
- }
- void
- rw_attr_delete0()
- {
- int attr = (int) rw_code[mach.pc++];
- grad_avl_delete(&mach.req->avlist, attr);
- }
- void
- rw_attr_delete()
- {
- int attr = (int) rw_code[mach.pc++];
- RWSTYPE index;
- assert_request_presence();
- cpopn(&index);
- grad_avl_delete_n(&mach.req->avlist, attr, index);
- }
- /*
- * Pop (and discard) a value from stack
- */
- void
- rw_popn()
- {
- RWSTYPE n;
- cpopn(&n);
- }
- /*
- * Pop a value from stack into the accumulator
- */
- void
- rw_popa()
- {
- cpopn(&mach.rA);
- }
- /*
- * Push accumulator on stack
- */
- void
- rw_pusha()
- {
- pushn(mach.rA);
- }
- /*
- * String concatenation
- */
- void
- rw_adds()
- {
- grad_string_t s1, s2;
- RWSTYPE *p;
- char *s;
-
- checkpop(2);
- poparr(&s2);
- poparr(&s1);
- p = heap_reserve(sizeof(RWSTYPE) + s1.size + s2.size + 1);
- s = (char*)(p + 1);
- memcpy(s, s1.data, s1.size);
- s += s1.size;
- memcpy(s, s2.data, s2.size);
- s += s2.size;
- *s = 0;
- p[0] = s1.size + s2.size;
- pushn((RWSTYPE)p);
- }
- /*
- * Unary negation
- */
- void
- rw_neg()
- {
- checkpop(1);
- pushn(-popn());
- }
- /*
- * Bitwise operations
- */
- void
- rw_b_and()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1 & n2);
- }
- void
- rw_b_or()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1 | n2);
- }
- void
- rw_b_xor()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1 ^ n2);
- }
- void
- rw_shl()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1 << n2);
- }
- void
- rw_shr()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1 >> n2);
- }
- /*
- * Addition
- */
- void
- rw_add()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1+n2);
- }
- /*
- * Subtraction
- */
- void
- rw_sub()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1-n2);
- }
- /*
- * Multiplication
- */
- void
- rw_mul()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1*n2);
- }
- /*
- * Division
- */
- void
- rw_div()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- if (n2 == 0)
- rw_error(_("division by zero!"));
- pushn(n1/n2);
- }
- /*
- * Remainder
- */
- void
- rw_rem()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- if (n2 == 0)
- rw_error(_("division by zero!"));
- pushn(n1%n2);
- }
- /* Type conversion */
- void
- rw_i2s()
- {
- int n = popn();
- char buf[64];
-
- snprintf(buf, sizeof(buf), "%d", n);
- pushstr(buf, strlen(buf));
- }
- void
- rw_s2i()
- {
- grad_string_t s;
- mem2string(&s, (RWSTYPE *)popn());
- pushn(strtol(s.data, NULL, 0));
- }
- void
- rw_eq()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1 == n2);
- }
- void
- rw_ne()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1 != n2);
- }
- void
- rw_lt()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1 < n2);
- }
- void
- rw_le()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1 <= n2);
- }
- void
- rw_gt()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1 > n2);
- }
- void
- rw_ge()
- {
- int n1, n2;
- checkpop(2);
- n2 = popn();
- n1 = popn();
- pushn(n1 >= n2);
- }
- void
- rw_eqs()
- {
- grad_string_t s1, s2;
- checkpop(2);
- poparr(&s2);
- poparr(&s1);
-
- pushn(s1.size == s2.size && memcmp(s1.data, s2.data, s1.size) == 0);
- }
- void
- rw_nes()
- {
- grad_string_t s1, s2;
- checkpop(2);
- poparr(&s2);
- poparr(&s1);
-
- pushn(!(s1.size == s2.size && memcmp(s1.data, s2.data, s1.size) == 0));
- }
- void
- rw_lts()
- {
- grad_string_t s1, s2;
- size_t size;
-
- checkpop(2);
- poparr(&s2);
- poparr(&s1);
- size = RW_MIN(s1.size, s2.size);
- pushn(memcmp(s1.data, s2.data, size < 0) || s1.size < s2.size);
- }
- void
- rw_les()
- {
- grad_string_t s1, s2;
- size_t size;
-
- checkpop(2);
- poparr(&s2);
- poparr(&s1);
- size = RW_MIN(s1.size, s2.size);
- pushn(memcmp(s1.data, s2.data, size <= 0) || s1.size <= s2.size);
- }
- void
- rw_gts()
- {
- grad_string_t s1, s2;
- size_t size;
-
- checkpop(2);
- poparr(&s2);
- poparr(&s1);
- size = RW_MIN(s1.size, s2.size);
- pushn(memcmp(s1.data, s2.data, size > 0) || s1.size > s2.size);
- }
- void
- rw_ges()
- {
- grad_string_t s1, s2;
- size_t size;
-
- checkpop(2);
- poparr(&s2);
- poparr(&s1);
- size = RW_MIN(s1.size, s2.size);
- pushn(memcmp(s1.data, s2.data, size >= 0) || s1.size >= s2.size);
- }
- void
- rw_not()
- {
- int n;
- checkpop(1);
- n = popn();
- pushn(!n);
- }
- static void
- need_pmatch(size_t n)
- {
- n++;
- if (mach.nmatch < n) {
- grad_free(mach.pmatch);
- mach.nmatch = n;
- mach.pmatch = grad_emalloc(n * sizeof(mach.pmatch[0]));
- }
- }
- void
- rw_match()
- {
- COMP_REGEX *rx = (COMP_REGEX *)rw_code[mach.pc++];
- grad_string_t s;
- int rc;
- poparr(&s);
- need_pmatch(rx->nmatch);
- mach.sA = s.data;
-
- rc = regexec(&rx->regex, mach.sA,
- rx->nmatch + 1, mach.pmatch, 0);
- if (rc && GRAD_DEBUG_LEVEL(1)) {
- char errbuf[512];
- regerror(rc, &rx->regex,
- errbuf, sizeof(errbuf));
- grad_log(GRAD_LOG_DEBUG,
- _("rewrite regex failure: %s. Input: %s"),
- errbuf, (char*)mach.rA);
- }
- pushn(rc == 0);
- }
- void
- rw_jmp()
- {
- pctr_t pc = (pctr_t) rw_code[mach.pc++];
- mach.pc = pc;
- }
- void
- rw_jne()
- {
- int n;
- pctr_t pc = (pctr_t) rw_code[mach.pc++];
-
- n = popn();
- if (n != 0)
- mach.pc = pc;
- }
- void
- rw_je()
- {
- int n;
- pctr_t pc = (pctr_t) rw_code[mach.pc++];
-
- n = popn();
- if (n == 0)
- mach.pc = pc;
- }
- void
- rw_builtin()
- {
- INSTR fun = (INSTR) rw_code[mach.pc++];
- pushn(mach.pc);
- enter(0);
- fun();
- leave();
- }
- void
- run(pctr_t pc)
- {
- mach.pc = pc;
- while (rw_code[mach.pc]) {
- if (mach.pc >= rw_codesize)
- rw_error(_("pc out of range"));
- (*(rw_code[mach.pc++]))();
- }
- }
- /* ****************************************************************************
- * A placeholder for the garbage collector
- */
- void
- gc()
- {
- }
- /* ****************************************************************************
- * Built-in functions
- */
- /*
- * integer length(string s)
- */
- static void
- bi_length()
- {
- grad_string_t s;
- mem2string(&s, (RWSTYPE*)getarg(1));
- pushn(s.size);
- }
- /*
- * integer index(string s, integer a)
- */
- static void
- bi_index()
- {
- grad_string_t s;
- char *p;
- int c;
- mem2string(&s, (RWSTYPE*) getarg(2));
- c = (int) getarg(1);
- p = memchr(s.data, c, s.size);
- pushn(p ? p - s.data : -1);
- }
- /*
- * integer rindex(string s, integer a)
- */
- static void
- bi_rindex()
- {
- grad_string_t s;
- int i;
- int c;
- mem2string(&s, (RWSTYPE*) getarg(2));
- for (i = s.size - 1; i >= 0; i--)
- if (s.data[i] == c)
- break;
- pushn(i);
- }
- /*
- * string substr(string s, int start, int length)
- */
- static void
- bi_substr()
- {
- grad_string_t src;
- RWSTYPE *p;
- char *dest;
- int start, length;
- mem2string(&src, (RWSTYPE*)getarg(3));
- start = getarg(2);
- length = getarg(1);
- if (length < 0)
- length = src.size - start;
-
- p = heap_reserve(sizeof(RWSTYPE) + length + 1);
- dest = (char *)(p + 1);
- if (length > 0)
- memcpy(dest, src.data + start, length);
- dest[length] = 0;
- p[0] = length;
- pushn((RWSTYPE)p);
- }
- static void
- bi_field()
- {
- grad_string_t str;
- char *p, *endp;
- int fn = getarg(1);
- char *s = "";
- int len = 1;
-
- mem2string(&str, (RWSTYPE*) getarg(2));
- endp = str.data + str.size;
- for (p = str.data; p < endp && fn--; ) {
- /* skip initial whitespace */
- while (p < endp && isspace(*p))
- p++;
- s = p;
- len = 0;
- while (p < endp && !isspace(*p)) {
- p++;
- len++;
- }
- }
- if (p == endp && fn)
- pushstr("", 0);
- else
- pushstr(s, len);
- }
- static void
- bi_logit()
- {
- grad_string_t msg;
- mem2string(&msg, (RWSTYPE*) getarg(1));
- grad_log(GRAD_LOG_INFO, "%s", msg.data);
- pushn(0);
- }
- static void
- bi_htonl()
- {
- pushn(htonl(getarg(1)));
- }
- static void
- bi_ntohl()
- {
- pushn(ntohl(getarg(1)));
- }
- static void
- bi_htons()
- {
- pushn(htons(getarg(1) & 0xffff));
- }
- static void
- bi_ntohs()
- {
- pushn(ntohs(getarg(1) & 0xffff));
- }
- static void
- bi_inet_ntoa()
- {
- char buffer[GRAD_IPV4_STRING_LENGTH];
- char *s = grad_ip_iptostr(getarg(1), buffer);
- pushstr(s, strlen(s));
- }
- static void
- bi_inet_aton()
- {
- grad_string_t s;
- mem2string(&s, (RWSTYPE*)getarg(1));
- /* Note: inet_aton is not always present. See lib/iputils.c */
- pushn(grad_ip_strtoip(s.data));
- }
- static void
- bi_tolower()
- {
- grad_string_t src;
- grad_string_t dest;
- int i;
- mem2string(&src, (RWSTYPE*) getarg(1));
- pushstr(src.data, src.size);
- mem2string(&dest, (RWSTYPE*) tos());
- for (i = 0; i < dest.size; i++)
- dest.data[i] = tolower(dest.data[i]);
- }
- static void
- bi_toupper()
- {
- grad_string_t src;
- grad_string_t dest;
- int i;
- mem2string(&src, (RWSTYPE*) getarg(1));
- pushstr(src.data, src.size);
- mem2string(&dest, (RWSTYPE*) tos());
- for (i = 0; i < dest.size; i++)
- dest.data[i] = toupper(dest.data[i]);
- }
- static void
- bi_request_code_string()
- {
- int code = (int) getarg(1);
- const char *s = grad_request_code_to_name(code);
- pushstr(s, strlen(s));
- }
- static void
- bi_request_source_ip()
- {
- assert_request_presence();
- pushn((RWSTYPE) mach.req->ipaddr);
- }
- static void
- bi_request_source_port()
- {
- assert_request_presence();
- pushn((RWSTYPE) mach.req->udp_port);
- }
- static void
- bi_request_id()
- {
- assert_request_presence();
- pushn((RWSTYPE) mach.req->id);
- }
- static void
- bi_request_code()
- {
- assert_request_presence();
- pushn((RWSTYPE) mach.req->code);
- }
- static void
- bi_nas_name()
- {
- grad_nas_t *nas;
- grad_uint32_t ip = (grad_uint32_t) getarg(1);
- if ((nas = grad_nas_lookup_ip(ip)) != NULL) {
- char *s = nas->shortname[0] ? nas->shortname : nas->longname;
- pushstr(s, strlen(s));
- } else {
- char nasname[GRAD_MAX_LONGNAME];
-
- grad_ip_gethostname(ip, nasname, sizeof(nasname));
- pushstr(nasname, strlen(nasname));
- }
- }
- static void
- bi_nas_short_name()
- {
- grad_nas_t *nas;
- grad_uint32_t ip = (grad_uint32_t) getarg(1);
- if ((nas = grad_nas_lookup_ip(ip)) && nas->shortname[0]) {
- pushstr(nas->shortname, strlen(nas->shortname));
- } else {
- char nasname[GRAD_MAX_LONGNAME];
-
- grad_ip_gethostname(ip, nasname, sizeof(nasname));
- pushstr(nasname, strlen(nasname));
- }
- }
- static void
- bi_nas_full_name()
- {
- grad_nas_t *nas;
- grad_uint32_t ip = (grad_uint32_t) getarg(1);
- if ((nas = grad_nas_lookup_ip(ip)) != NULL) {
- pushstr(nas->longname, strlen(nas->longname));
- } else {
- char nasname[GRAD_MAX_LONGNAME];
-
- grad_ip_gethostname(ip, nasname, sizeof(nasname));
- pushstr(nasname, strlen(nasname));
- }
- }
- static void
- bi_gethostbyaddr()
- {
- grad_uint32_t ip = (grad_uint32_t) getarg(1);
- char nasname[GRAD_MAX_LONGNAME];
-
- grad_ip_gethostname(ip, nasname, sizeof(nasname));
- pushstr(nasname, strlen(nasname));
- }
- static void
- bi_gethostbyname()
- {
- grad_string_t s;
- mem2string(&s, (RWSTYPE*)getarg(1));
- pushn((RWSTYPE) grad_ip_gethostaddr(s.data));
- }
- static void
- bi_time()
- {
- pushn((RWSTYPE) time(NULL));
- }
- static void
- bi_strftime()
- {
- struct tm *tm;
- char *base;
- time_t t = (time_t) getarg(1);
- grad_string_t fmt;
- size_t n;
-
- mem2string(&fmt, (RWSTYPE*) getarg(2));
- tm = localtime(&t);
- base = temp_space_create();
- n = strftime(base, temp_space_size(), fmt.data, tm);
- pushstr(base, n);
- }
- static void
- rw_regerror(const char *prefix, regex_t *rx, int rc)
- {
- size_t sz = regerror(rc, rx, NULL, 0);
- char *errbuf = malloc(sz + strlen (prefix) + 1);
- if (!errbuf)
- rw_error(prefix);
- else {
- strcpy (errbuf, prefix);
- regerror(rc, rx, errbuf + strlen(prefix), sz);
- rw_error_free(errbuf);
- }
- }
- enum subst_segment_type {
- subst_text, /* pure text */
- subst_ref, /* back reference (\NN) */
- subst_match /* substitute whole match (&) */
- };
- struct subst_segment {
- enum subst_segment_type type;
- union {
- struct {
- char *ptr;
- size_t len;
- } text; /* type == subst_text */
- size_t ref; /* type == subst_ref */
- } v;
- };
- static void
- add_text_segment(grad_list_t *lst, char *ptr, char *end)
- {
- struct subst_segment *seg;
- if (ptr >= end)
- return;
- seg = grad_emalloc(sizeof(*seg));
- seg->type = subst_text;
- seg->v.text.ptr = ptr;
- seg->v.text.len = end - ptr;
- grad_list_append(lst, seg);
- }
- static void
- add_match_segment(grad_list_t *lst)
- {
- struct subst_segment *seg = grad_emalloc(sizeof(*seg));
- seg->type = subst_match;
- grad_list_append(lst, seg);
- }
- static void
- add_ref_segment(grad_list_t *lst, size_t ref)
- {
- struct subst_segment *seg = grad_emalloc(sizeof(*seg));
- seg->type = subst_ref;
- seg->v.ref = ref;
- grad_list_append(lst, seg);
- }
- grad_list_t *
- subst_create(char *text)
- {
- char *p;
- grad_list_t *lst = grad_list_create();
- if (!lst)
- return lst;
- p = text;
- while (*p) {
- if (*p == '\\' && p[1]) {
- if (p[1] == '&') {
- add_text_segment(lst, text, p);
- text = ++p;
- p++;
- } else if (p[1] == '\\') {
- add_text_segment(lst, text, p+1);
- p += 2;
- text = p;
- } else if (isdigit(p[1])) {
- size_t ref;
- char *q;
-
- add_text_segment(lst, text, p);
- ref = strtoul(p+1, &q, 10);
- add_ref_segment(lst, ref);
- text = p = q;
- } else {
- add_text_segment(lst, text, p);
- text = ++p;
- }
- } else if (*p == '&') {
- add_text_segment(lst, text, p);
- add_match_segment(lst);
- text = ++p;
- } else
- p++;
- }
- add_text_segment(lst, text, p);
- return lst;
- }
- int
- seg_free(void *item, void *data ARG_UNUSED)
- {
- grad_free(item);
- return 0;
- }
- void
- subst_destroy(grad_list_t *lst)
- {
- grad_list_destroy(&lst, seg_free, NULL);
- }
- void
- subst_run(grad_list_t *subst, size_t nsub,
- char **baseptr, char *arg)
- {
- grad_iterator_t *itr = grad_iterator_create(subst);
- struct subst_segment *seg;
-
- for (seg = grad_iterator_first(itr); seg; seg = grad_iterator_next(itr)) {
- switch (seg->type) {
- case subst_text:
- temp_space_copy(baseptr,
- seg->v.text.ptr, seg->v.text.len);
- break;
-
- case subst_ref:
- if (seg->v.ref >= nsub)
- rw_error(_("Invalid backreference"));
- temp_space_copy(baseptr,
- arg + mach.pmatch[seg->v.ref].rm_so,
- mach.pmatch[seg->v.ref].rm_eo -
- mach.pmatch[seg->v.ref].rm_so);
- break;
-
- case subst_match:
- temp_space_copy(baseptr,
- arg + mach.pmatch[0].rm_so,
- mach.pmatch[0].rm_eo -
- mach.pmatch[0].rm_so);
- }
- }
- grad_iterator_destroy(&itr);
- }
- static void
- bi_gsub()
- {
- grad_string_t re_str;
- grad_string_t repl;
- grad_string_t arg;
- char *p;
- char *base;
- regex_t rx;
- grad_list_t *subst;
- int rc;
-
- mem2string(&re_str, (RWSTYPE*) getarg(3));
- mem2string(&repl, (RWSTYPE*) getarg(2));
- mem2string(&arg, (RWSTYPE*) getarg(1));
- p = arg.data;
-
- rc = regcomp(&rx, re_str.data, regcomp_flags);
- if (rc)
- rw_regerror(_("regexp compile error: "), &rx, rc);
- need_pmatch(rx.re_nsub);
- subst = subst_create(repl.data);
- if (!subst)
- rw_error(_("gsub: not enough memory"));
-
- base = temp_space_create();
- while (*p
- && regexec(&rx, p, rx.re_nsub + 1, mach.pmatch, 0) == 0) {
- temp_space_copy(&base, p, mach.pmatch[0].rm_so);
- subst_run(subst, rx.re_nsub + 1, &base, p);
- p += mach.pmatch[0].rm_eo;
- if (mach.pmatch[0].rm_eo == 0)
- p++;
- }
- temp_space_copy(&base, p, strlen(p) + 1);
- subst_destroy(subst);
- regfree(&rx);
- pushn((RWSTYPE)temp_space_fix(base));
- }
- static void
- bi_sub()
- {
- grad_string_t re_str;
- grad_string_t repl;
- grad_string_t arg;
- char *p;
- char *base;
- regex_t rx;
- grad_list_t *subst;
- int rc;
-
- mem2string(&re_str, (RWSTYPE*) getarg(3));
- mem2string(&repl, (RWSTYPE*) getarg(2));
- mem2string(&arg, (RWSTYPE*) getarg(1));
-
- rc = regcomp(&rx, re_str.data, regcomp_flags);
- if (rc)
- rw_regerror(_("regexp compile error: "), &rx, rc);
- need_pmatch(rx.re_nsub);
- subst = subst_create(repl.data);
- if (!subst)
- rw_error(_("sub: not enough memory"));
-
- base = temp_space_create();
- p = arg.data;
- if (regexec(&rx, p, rx.re_nsub + 1, mach.pmatch, 0) == 0) {
- temp_space_copy(&base, p, mach.pmatch[0].rm_so);
- subst_run(subst, rx.re_nsub + 1, &base, p);
- p += mach.pmatch[0].rm_eo;
- }
- temp_space_copy(&base, p, strlen(p) + 1);
- subst_destroy(subst);
- regfree(&rx);
- pushn((RWSTYPE)temp_space_fix(base));
- }
- #define ISPRINT(c) (((unsigned char)c) < 128 && (isalnum(c) || c == '-'))
- static void
- bi_qprn()
- {
- grad_string_t arg;
- char *p, *s, *end;
- size_t count;
- RWSTYPE *sp;
-
- mem2string(&arg, (RWSTYPE*)getarg(1));
- end = arg.data + arg.size;
- for (count = 0, p = arg.data; p < end; p++)
- if (!ISPRINT(*p))
- count++;
- /* Each encoded character takes 3 bytes. */
- sp = heap_reserve(sizeof(RWSTYPE) + arg.size + 2*count + 1);
- sp[0] = arg.size + 2*count;
- pushn((RWSTYPE) sp);
-
- for (p = (char*)(sp + 1), s = arg.data; s < end; s++) {
- if (ISPRINT(*s))
- *p++ = *s;
- else {
- char buf[3];
- snprintf(buf, sizeof buf, "%02X", *(unsigned char*)s);
- *p++ = '%';
- *p++ = buf[0];
- *p++ = buf[1];
- }
- }
- *p = 0;
- }
- static void
- bi_quote_string()
- {
- int quote;
- grad_string_t arg;
- RWSTYPE *sp;
- char *p;
- size_t size;
-
- mem2string(&arg, (RWSTYPE*)getarg(1));
- size = grad_argcv_quoted_length_n(arg.data, arg.size, "e);
- sp = heap_reserve(sizeof(RWSTYPE) + size + 1);
- sp[0] = size;
- pushn((RWSTYPE)sp);
- p = (char*)(sp + 1);
- grad_argcv_quote_copy_n(p, arg.data, arg.size);
- }
- static void
- bi_unquote_string()
- {
- int quote;
- grad_string_t arg;
- RWSTYPE *sp;
- char *p;
- size_t size;
-
- mem2string(&arg, (RWSTYPE*)getarg(1));
- sp = heap_reserve(sizeof(RWSTYPE) + arg.size + 1);
- p = (char*)(sp + 1);
- grad_argcv_unquote_copy(p, arg.data, arg.size);
- sp[0] = strlen(p);
- pushn((RWSTYPE)sp);
- }
- static void
- bi_textdomain()
- {
- grad_string_t s;
- mem2string(&s, (RWSTYPE*)getarg(1));
- pushstr(default_gettext_domain, strlen (default_gettext_domain));
- grad_string_replace(&default_gettext_domain, s.data);
- }
- static void
- bi_gettext()
- {
- grad_string_t s;
- const char *p;
-
- mem2string(&s, (RWSTYPE*)getarg(1));
- p = dgettext(default_gettext_domain, s.data);
- pushstr(p, strlen(p));
- }
- static void
- bi_dgettext()
- {
- grad_string_t domain;
- grad_string_t text;
- const char *p;
-
- mem2string(&domain, (RWSTYPE*)getarg(2));
- mem2string(&text, (RWSTYPE*)getarg(1));
- p = dgettext(domain.data, text.data);
- pushstr(p, strlen(p));
- }
- static void
- bi_ngettext()
- {
- grad_string_t s;
- grad_string_t pl;
- unsigned long n;
- const char *p;
- mem2string(&s, (RWSTYPE*)getarg(3));
- mem2string(&pl, (RWSTYPE*)getarg(2));
- n = (unsigned long) getarg(1);
- p = dngettext(default_gettext_domain,
- s.data,
- pl.data,
- n);
- pushstr(p, strlen(p));
- }
- static void
- bi_dngettext()
- {
- grad_string_t domain;
- grad_string_t s;
- grad_string_t pl;
- unsigned long n;
- const char *p;
- mem2string(&domain, (RWSTYPE*)getarg(4));
- mem2string(&s, (RWSTYPE*)getarg(3));
- mem2string(&pl, (RWSTYPE*)getarg(2));
- n = (unsigned long) getarg(1);
- p = dngettext(domain.data, s.data, pl.data, n);
- pushstr(p, strlen(p));
- }
- static builtin_t builtin[] = {
- { bi_length, "length", Integer, "s" },
- { bi_index, "index", Integer, "si" },
- { bi_rindex, "rindex", Integer, "si" },
- { bi_substr, "substr", String, "sii" },
- { bi_logit, "logit", Integer, "s" },
- { bi_field, "field", String, "si" },
- { bi_ntohl, "ntohl", Integer, "i" },
- { bi_htonl, "htonl", Integer, "i" },
- { bi_ntohs, "ntohs", Integer, "i" },
- { bi_htons, "htons", Integer, "i" },
- { bi_inet_ntoa, "inet_ntoa", String, "i" },
- { bi_inet_aton, "inet_aton", Integer, "s" },
- { bi_sub, "sub", String, "sss" },
- { bi_gsub, "gsub", String, "sss" },
- { bi_qprn, "qprn", String, "s" },
- { bi_tolower, "tolower", String, "s" },
- { bi_toupper, "toupper", String, "s" },
- { bi_unquote_string, "unquote_string", String, "s" },
- { bi_quote_string, "quote_string", String, "s" },
- { bi_request_code_string, "request_code_string", String, "i" },
- /* i18n support */
- { bi_gettext, "gettext", String, "s" },
- { bi_gettext, "_", String, "s" },
- { bi_dgettext, "dgettext", String, "ss" },
- { bi_ngettext, "ngettext", String, "ssi" },
- { bi_dngettext, "dngettext", String, "sssi" },
- { bi_textdomain, "textdomain", String, "s" },
- /* Request internals */
- { bi_request_source_ip, "request_source_ip", Integer, "" },
- { bi_request_source_port, "request_source_port", Integer, "" },
- { bi_request_id, "request_id", Integer, "" },
- { bi_request_code, "request_code", Integer, "" },
- /* Radius database */
- { bi_nas_name, "nas_name", String, "i" },
- { bi_nas_short_name, "nas_short_name", String, "i" },
- { bi_nas_full_name, "nas_full_name", String, "i" },
- /* DNS lookups */
- { bi_gethostbyaddr, "gethostbyaddr", Integer, "s" },
- { bi_gethostbyname, "gethostbyname", String, "i" },
- /* Time functions */
- { bi_time, "time", Integer, "" },
- { bi_strftime, "strftime", String, "si" },
- { NULL }
- };
- builtin_t *
- builtin_lookup(char *name)
- {
- int i;
- for (i = 0; builtin[i].handler; i++)
- if (strcmp(name, builtin[i].name) == 0)
- return &builtin[i];
- return NULL;
- }
- /* ****************************************************************************
- * Function registering/unregistering
- */
- int
- function_free(FUNCTION *f)
- {
- PARAMETER *parm, *next;
-
- rx_free(f->rx_list);
- parm = f->parm;
- while (parm) {
- next = parm->next;
- grad_free(parm);
- parm = next;
- }
- return 0;
- }
-
- FUNCTION *
- function_install(FUNCTION *fun)
- {
- FUNCTION *fp;
- if (fp = (FUNCTION *)grad_sym_lookup(rewrite_tab, fun->name)) {
- grad_log_loc(GRAD_LOG_ERR, &fun->loc,
- _("redefinition of function %s"));
- grad_log_loc(GRAD_LOG_ERR, &fp->loc,
- _("previously defined here"));
- errcnt++;
- return fp;
- }
- fp = (FUNCTION*)grad_sym_install(rewrite_tab, fun->name);
-
- fp->rettype = fun->rettype;
- fp->entry = fun->entry;
- fp->rx_list = fun->rx_list;
- fp->nparm = fun->nparm;
- fp->parm = fun->parm;
- fp->stack_alloc = fun->stack_alloc;
- fp->loc = fun->loc;
- return fp;
- }
- /* ****************************************************************************
- * Runtime functions
- */
- static char pair_print_prefix[] = " ";
- static void
- rw_mach_init()
- {
- memset(&mach, 0, sizeof(mach));
- if (!runtime_stack)
- runtime_stack = grad_emalloc(rewrite_stack_size *
- sizeof(runtime_stack[0]));
-
- mach.stack = runtime_stack;
- mach.st = 0; /* Stack top */
- mach.ht = rewrite_stack_size - 1; /* Heap top */
- grad_string_replace(&default_gettext_domain, PACKAGE);
- }
- static void
- rw_mach_destroy()
- {
- grad_free(mach.pmatch);
- mach.pmatch = NULL;
- }
- FUNCTION *
- rewrite_check_function(const char *name, grad_data_type_t rettype, char *typestr)
- {
- int i;
- PARAMETER *p;
-
- FUNCTION *fun = (FUNCTION*) grad_sym_lookup(rewrite_tab, name);
- if (!fun) {
- grad_log(GRAD_LOG_ERR, _("function %s not defined"), name);
- return NULL;
- }
- if (fun->rettype != rettype) {
- grad_log(GRAD_LOG_ERR, _("function %s returns wrong data type"), name);
- return NULL;
- }
- for (i = 0, p = fun->parm; i < fun->nparm; i++, p = p->next) {
- switch (typestr[i]) {
- case 0:
- grad_log(GRAD_LOG_ERR,
- _("function %s takes too many arguments"),
- name);
- return NULL;
-
- case 'i':
- if (p->datatype != Integer) {
- grad_log(GRAD_LOG_ERR,
- _("function %s: argument %d must be integer"),
- name, i+1);
- return NULL;
- }
- break;
-
- case 's':
- if (p->datatype != String) {
- grad_log(GRAD_LOG_ERR,
- _("function %s: argument %d must be string"),
- name, i+1);
- return NULL;
- }
- break;
-
- default:
- grad_insist_fail("bad datatype");
- }
- }
- if (typestr[i]) {
- grad_log(GRAD_LOG_ERR,
- _("function %s takes too few arguments"),
- name);
- return NULL;
- }
- return fun;
- }
- int
- run_init(pctr_t pc, grad_request_t *request)
- {
- FILE *fp;
- rw_mach_init();
- if (setjmp(mach.jmp)) {
- rw_mach_destroy();
- return -1;
- }
-
- mach.req = request;
- if (GRAD_DEBUG_LEVEL(2)) {
- fp = debug_open_file();
- fprintf(fp, "Before rewriting:\n");
- grad_avl_fprint(fp, pair_print_prefix, 1, AVPLIST(&mach));
- fclose(fp);
- }
- /* Imitate a function call */
- pushn(0); /* Return address */
- run(pc); /* call function */
- if (GRAD_DEBUG_LEVEL(2)) {
- fp = debug_open_file();
- fprintf(fp, "After rewriting\n");
- grad_avl_fprint(fp, pair_print_prefix, 1, AVPLIST(&mach));
- fclose(fp);
- }
- rw_mach_destroy();
- return 0;
- }
- static void
- return_value(grad_value_t *val)
- {
- u_char *p;
-
- switch (val->type) {
- case Integer:
- val->datum.ival = mach.rA;
- break;
-
- case String:
- mem2string(&val->datum.sval, (RWSTYPE*) mach.rA);
- p = grad_emalloc (val->datum.sval.size + 1);
- memcpy (p, val->datum.sval.data, val->datum.sval.size);
- p[val->datum.sval.size] = 0;
- val->datum.sval.data = p;
- break;
-
- default:
- abort();
- }
- }
- static int
- evaluate(pctr_t pc, grad_request_t *req, grad_value_t *val)
- {
- if (run_init(pc, req))
- return -1;
- if (val)
- return_value(val);
- return 0;
- }
- int
- rewrite_invoke(grad_data_type_t rettype, grad_value_t *val,
- const char *name,
- grad_request_t *request, char *typestr, ...)
- {
- FILE *fp;
- va_list ap;
- FUNCTION *fun;
- int nargs;
- char *s;
- fun = rewrite_check_function(name, rettype, typestr);
- if (!fun)
- return -1;
- rw_mach_init();
- if (setjmp(mach.jmp)) {
- rw_mach_destroy();
- return -1;
- }
-
- mach.req = request;
- if (GRAD_DEBUG_LEVEL(2)) {
- fp = debug_open_file();
- fprintf(fp, "Before rewriting:\n");
- grad_avl_fprint(fp, pair_print_prefix, 1, AVPLIST(&mach));
- fclose(fp);
- }
- /* Pass arguments */
- nargs = 0;
- va_start(ap, typestr);
- while (*typestr) {
- nargs++;
- switch (*typestr++) {
- case 'i':
- pushn(va_arg(ap, int));
- break;
- case 's':
- s = va_arg(ap, char*);
- pushstr(s, strlen(s));
- break;
- default:
- grad_insist_fail("bad datatype");
- }
- }
- va_end(ap);
- /* Imitate a function call */
- pushn(0); /* Return address */
- run(fun->entry); /* call function */
- if (GRAD_DEBUG_LEVEL(2)) {
- fp = debug_open_file();
- fprintf(fp, "After rewriting\n");
- grad_avl_fprint(fp, pair_print_prefix, 1, AVPLIST(&mach));
- fclose(fp);
- }
- val->type = fun->rettype;
- return_value(val);
- rw_mach_destroy();
- return 0;
- }
- char *
- rewrite_compile(char *expr)
- {
- int rc;
- FUNCTION *fun;
- char *name = grad_emalloc(strlen(expr) + 3);
- sprintf(name, "$%s$", expr);
- fun = (FUNCTION*) grad_sym_lookup(rewrite_tab, name);
- if (!fun) {
- rc = parse_rewrite_string(expr);
- if (rc) {
- grad_free(name);
- return NULL;
- }
- function->name = name;
- function_install(function);
- }
- return name;
- }
- int
- rewrite_interpret(char *expr, grad_request_t *req, grad_value_t *val)
- {
- pctr_t save_pc = rw_pc;
- int rc;
-
- rc = parse_rewrite_string(expr);
- rw_pc = save_pc;
- if (rc)
- return rc;
- val->type = return_type;
- if (return_type == Undefined)
- return -1;
- return evaluate(rw_pc, req, val);
- }
- int
- rewrite_eval(char *symname, grad_request_t *req, grad_value_t *val)
- {
- FUNCTION *fun;
-
- fun = (FUNCTION*) grad_sym_lookup(rewrite_tab, symname);
- if (!fun)
- return -1;
-
- if (fun->nparm) {
- grad_log(GRAD_LOG_ERR,
- ngettext("function %s() requires %d parameter",
- "function %s() requires %d parameters",
- fun->nparm),
- fun->name, fun->nparm);
- return -1;
- }
- if (val)
- val->type = fun->rettype;
- return evaluate(fun->entry, req, val);
- }
-
- /* ****************************************************************************
- * Configuration
- */
- static grad_list_t *source_list; /* List of loaded source files */
- static grad_list_t *rewrite_load_path; /* Load path list */
- /* Add a path to load path */
- static void
- rewrite_add_load_path(const char *str)
- {
- if (!rewrite_load_path)
- rewrite_load_path = grad_list_create();
- grad_list_append(rewrite_load_path, grad_estrdup(str));
- }
- void
- register_source_name(char *path)
- {
- if (!source_list)
- source_list = grad_list_create();
- grad_list_append(source_list, path);
- }
- struct load_data {
- int rc;
- char *name;
- };
- /* Try to load a source file.
- ITEM is a directory name, DATA is struct load_data.
- Return 1 if the file was found (no matter was it loaded or not) */
- static int
- try_load(void *item, void *data)
- {
- int rc = 0;
- struct load_data *lp = data;
- char *path = grad_mkfilename((char*)item, lp->name);
- lp->rc = parse_rewrite(path);
- if (lp->rc >= 0) {
- register_source_name(path);
- rc = 1;
- } else
- grad_free(path);
- return rc;
- }
- /* Load the given rewrite module. */
- int
- rewrite_load_module(char *name)
- {
- int rc;
- if (name[0] == '/') {
- register_source_name(grad_estrdup(name));
- rc = parse_rewrite(name);
- } else {
- struct load_data ld;
- ld.rc = 1;
- ld.name = name;
- grad_list_iterate(rewrite_load_path, try_load, &ld);
- rc = ld.rc;
- }
- return rc;
- }
- static int
- free_path(void *item, void *data ARG_UNUSED)
- {
- grad_free(item);
- return 0;
- }
- static grad_list_t *source_candidate_list; /* List of modules that are to
- be loaded */
- int
- rewrite_stmt_term(int finish, void *block_data, void *handler_data)
- {
- if (!finish) {
- grad_symtab_clear(rewrite_tab);
-
- yydebug = GRAD_DEBUG_LEVEL(50);
- grad_list_destroy(&source_list, free_path, NULL);
- grad_list_destroy(&rewrite_load_path, free_path, NULL);
- rewrite_add_load_path(grad_config_dir);
- rewrite_add_load_path(RADIUS_DATADIR "/rewrite");
- grad_free(runtime_stack);
- runtime_stack = NULL;
- }
- return 0;
- }
- static int
- rewrite_cfg_add_load_path(int argc, cfg_value_t *argv,
- void *block_data, void *handler_data)
- {
- if (argc > 2) {
- cfg_argc_error(0);
- return 0;
- }
- if (argv[1].type != CFG_STRING) {
- cfg_type_error(CFG_STRING);
- return 0;
- }
- rewrite_add_load_path(argv[1].v.string);
- return 0;
- }
- static int
- rewrite_cfg_load(int argc, cfg_value_t *argv,
- void *block_data, void *handler_data)
- {
- if (argc > 2) {
- cfg_argc_error(0);
- return 0;
- }
- if (argv[1].type != CFG_STRING) {
- cfg_type_error(CFG_STRING);
- return 0;
- }
- grad_list_append(source_candidate_list, grad_estrdup(argv[1].v.string));
- return 0;
- }
- /* Configuration hooks and initialization */
- static void
- rewrite_before_config_hook(void *a ARG_UNUSED, void *b ARG_UNUSED)
- {
- grad_list_destroy(&source_candidate_list, free_path, NULL);
- source_candidate_list = grad_list_create();
- code_init();
- }
- static int
- _load_module(void *item, void *data ARG_UNUSED)
- {
- if (rewrite_load_module(item) == -2)
- grad_log(GRAD_LOG_ERR, _("file not found: %s"), item);
- return 0;
- }
- void
- rewrite_load_all(void *a ARG_UNUSED, void *b ARG_UNUSED)
- {
- if (!source_candidate_list)
- return;
-
- /* For compatibility with previous versions load the
- file $grad_config_dir/rewrite, if no explicit "load" statements
- were given */
- if (grad_list_count(source_candidate_list) == 0)
- rewrite_load_module("rewrite");
-
- grad_list_iterate(source_candidate_list, _load_module, NULL);
- #if defined(MAINTAINER_MODE)
- if (GRAD_DEBUG_LEVEL(100))
- debug_dump_code();
- #endif
- }
- void
- rewrite_init()
- {
- rewrite_tab = grad_symtab_create(sizeof(FUNCTION), function_free);
- radiusd_set_preconfig_hook(rewrite_before_config_hook, NULL, 0);
- }
- struct cfg_stmt rewrite_stmt[] = {
- { "stack-size", CS_STMT, NULL, cfg_get_number, &rewrite_stack_size,
- NULL, NULL },
- { "load-path", CS_STMT, NULL, rewrite_cfg_add_load_path, NULL, NULL, NULL },
- { "load", CS_STMT, NULL, rewrite_cfg_load, NULL, NULL, NULL },
- { NULL, }
- };
- size_t
- rewrite_get_stack_size()
- {
- return rewrite_stack_size;
- }
- void
- rewrite_set_stack_size(size_t s)
- {
- if (s == rewrite_stack_size)
- return;
- rewrite_stack_size = s;
- grad_free(runtime_stack);
- runtime_stack = NULL;
- }
-
- void
- grad_value_free(grad_value_t *val)
- {
- if (val->type == String)
- grad_free(val->datum.sval.data);
- }
- /* ****************************************************************************
- * Guile interface
- */
- #ifdef USE_SERVER_GUILE
- SCM
- radscm_datum_to_scm(grad_value_t *val)
- {
- switch (val->type) {
- case Integer:
- return scm_from_long(val->datum.ival);
- case String:
- /* FIXME! */
- return scm_from_locale_string(val->datum.sval.data);
- default:
- grad_insist_fail("Unknown data type");
- }
- return SCM_UNSPECIFIED;
- }
- int
- radscm_scm_to_ival(SCM cell, int *val)
- {
- if (scm_is_number(cell))
- *val = scm_to_int(cell);
- else if (SCM_CHARP(cell))
- *val = SCM_CHAR(cell);
- else if (scm_is_bool(cell))
- *val = scm_to_bool(cell);
- else if (scm_is_null(cell))
- *val = 0;
- else if (scm_is_string(cell)) {
- char *p, *str = scm_to_locale_string(cell);
- int x = strtol(str, &p, 0);
- int rc = *p ? -1 : 0;
- free(str);
- if (rc)
- return rc;
- } else
- return -1;
- return 0;
- }
- SCM
- radscm_rewrite_execute(const char *func_name, SCM ARGS)
- {
- char *name;
- FUNCTION *fun;
- PARAMETER *parm;
- int nargs;
- int n, rc;
- grad_value_t value;
- SCM cell;
- SCM FNAME;
- SCM retval;
-
- FNAME = SCM_CAR(ARGS);
- ARGS = SCM_CDR(ARGS);
- SCM_ASSERT(scm_is_string(FNAME), FNAME, SCM_ARG1, func_name);
- name = scm_to_locale_string(FNAME);
- fun = (FUNCTION*) grad_sym_lookup(rewrite_tab, name);
- free(name);
- if (!fun)
- scm_misc_error(func_name,
- _("function ~S not defined"),
- scm_list_1(FNAME));
-
- rw_mach_init();
- /* Pass arguments */
- nargs = 0;
- parm = fun->parm;
-
- for (cell = ARGS; !scm_is_null(cell);
- cell = SCM_CDR(cell), parm = parm->next) {
- SCM car = SCM_CAR(cell);
- if (++nargs > fun->nparm) {
- rw_code_unlock();
- scm_misc_error(func_name,
- _("too many arguments for ~S"),
- scm_list_1(FNAME));
- }
- switch (parm->datatype) {
- case Integer:
- rc = radscm_scm_to_ival(car, &n);
- if (!rc)
- pushn(n);
- break;
-
- case String:
- if (scm_is_string(car)) {
- char *p = scm_to_locale_string(car);
- pushstr(p, strlen(p));
- free(p);
- rc = 0;
- } else
- rc = 1;
- break;
- default:
- grad_insist_fail("Unknown data type");
- }
- if (rc) {
- rw_mach_destroy();
- scm_misc_error(func_name,
- _("type mismatch in argument ~S(~S) in call to ~S"),
- scm_list_3(scm_from_int(nargs),
- car,
- FNAME));
- }
- }
- if (fun->nparm != nargs) {
- rw_mach_destroy();
- scm_misc_error(func_name,
- _("too few arguments for ~S"),
- scm_list_1(FNAME));
- }
-
- /* Imitate a function call */
- if (setjmp(mach.jmp)) {
- rw_mach_destroy();
- return SCM_BOOL_F;
- }
- pushn(0); /* Return address */
- run(fun->entry); /* call function */
- value.type = fun->rettype;
- return_value(&value);
- retval = radscm_datum_to_scm(&value);
- grad_value_free(&value);
- rw_mach_destroy();
- return retval;
- }
- #endif
- /*HONY SOIT QUI MAL Y PENSE*/