/q-7.11/src/qc.y
Happy | 2193 lines | 1917 code | 276 blank | 0 comment | 0 complexity | 21795b0ef7f5c4c6fb9d19812dbf976d MD5 | raw file
Possible License(s): GPL-2.0
- /* expect 3 shift/reduce, 82 reduce/reduce */
- %{
- /* qc.y: yacc source of Q parser and Q compiler main program */
- /* Special case constructs (unary minus) and dangling else cause a number of
- parsing conflicts which are resolved correctly. */
- /* Q eQuational Programming System
- Copyright (c) 1991-2002 by Albert Graef
- <ag@muwiinfa.geschichte.uni-mainz.de>
- This program 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 1, or (at your option)
- any later version.
- This program 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 this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- */
- #include "qcdefs.h"
- int nerrs, nwarns;
- bool dflag, hflag, nflag, vflag, Vflag, wflag;
- volatile bool int_sig;
- char *self = "qc", *list = "";
- char signon[] = QC_SIGNON;
- char usage[] = QC_USAGE;
- char opts[4096];
- char copying[] = COPYING;
- char helpmsg[] = HELPMSG;
- DECLARE_YYTEXT
- extern int context, dcontext;
- static int type, fno_min, fno_max;
- static short flags, sflags;
- static unsigned long argv;
- static int qualtest = 0;
- static int isvsym(char *s);
- static void start_qualifiers(void), qualifiers(void);
- static void add_qualifier(EXPR *x);
- static void start_where_clauses(void), end_where_clauses(void),
- add_where_clause(EXPR *l, EXPR *r);
- static xvect_t *exprlist(void);
- static xvect_t *addexpr(xvect_t *v, EXPR *x);
- static xvect_t *groupexpr(xvect_t *v);
- static EXPR *tupleexpr(xvect_t *v);
- static EXPR *listexpr(xvect_t *v);
- static EXPR *streamexpr(xvect_t *v);
- %}
- %union {
- int ival;
- mpz_t zval;
- double fval;
- char *sval;
- EXPR *xval;
- xvect_t *xvval;
- }
- /* keywords and multi-character literals: */
- %token AS CONST DEF ELSE EXTERN FROM IF IMPORT INCLUDE OTHERWISE
- %token PRIVATE PUBLIC SPECIAL THEN TYPE UNDEF VAR VIRTUAL WHERE
- %token DOTDOT EQUIV
- /* identifiers and constants: */
- %token <ival> STR
- %token <sval> UID LID QUID QLID ID1 STR1
- %token <zval> INT
- %token <fval> FLOAT
- /* user-defined operators */
- %token <ival> OP0 OP1 OP2 OP3 OP4 OP5 OP6 OP7 OP8 OP9
- /* special tokens */
- %token ERRTOK EOFTOK
- /* ccc, xxx: identifiers in special declaration contexts. CAUTION: These must
- only be used in contexts where no lookahead is needed, so that the symbol
- to be handled has not been processed by the lexer already! */
- %type <ival> cccnid cccnfid
- /* CAUTION: The xxx nonterminals return unnormalized identifiers! */
- %type <ival> xxxqid xxxqfid xxxqfvid xxxqfid_or_op xxxqfid_or_op2 xxxqtid
- %type <ival> id nid fid nfid vid tid ntid fvid nfvid qvid vid_list
- %type <ival> opt_type type_alias id_alias op_alias op_prec
- %type <xval> condition
- %type <xval> lexpression0 llambda0 lsequence0 lcond0 lrightapp0 lrelation0
- %type <xval> expression0 lambda0 sequence0 cond0 rightapp0 relation0
- %type <xval> lexpression llambda lsequence lcond lrightapp lrelation laddition
- %type <xval> lmultiplication lunary lscript lcomposition lapplication lprimary
- %type <xval> expression lambda sequence cond rightapp relation addition
- %type <xval> multiplication unary script composition application primary atom
- %type <xvval> lexpr_list expr_list lexpr_list1 expr_list1 lexpr_list2 expr_list2
- %type <ival> op builtin_op seqop rappop relop0 relop addop mulop unop scriptop compop quoteop
- %type <sval> module_id
- %start source
- %%
- /* error recovery is fairly simplistic (panic mode with ';' as stop symbol),
- I should really work out something more sophisticated in the future -AG */
- source : { srcstate(); }
- program
- ;
- program : /* empty */
- | program imports ';'
- { import(); newdecl(); }
- | program includes ';'
- { include(); newdecl(); }
- | program named_imports ';'
- { import(); newdecl(); }
- | program named_includes ';'
- { include(); newdecl(); }
- | program priority
- { newdecl(); }
- | program declaration
- { newdecl(); }
- | program definition
- { newrule(); }
- | program rule
- { newrule(); }
- | program EOFTOK { wrapover(); }
- | program error { if (yychar == EOFTOK) wrapover(); }
- stopsyms
- { yyerrok; srcstate(); newrule(); newdecl(); clear_imports(); }
- ;
- stopsyms : ';' | EOFTOK
- ;
- imports : IMPORT import
- | imports ',' import
- ;
- includes : INCLUDE import
- | includes ',' import
- ;
- import : module_id
- { add_import($1, NULL); }
- | module_id AS module_id
- { add_import($1, $3); }
- ;
- module_id : ID1
- | STR1
- ;
- named_imports : FROM import IMPORT opt_imported_names
- ;
- named_includes : FROM import INCLUDE opt_imported_names
- ;
- opt_imported_names
- : /* empty: create a dummy list */
- { add_import_name(NULL, NULL); }
- | imported_names
- ;
- imported_names : imported_name
- | imported_names ',' imported_name
- ;
- imported_name : ID1
- { add_import_name($1, NULL); }
- | ID1 AS ID1
- { add_import_name($1, $3); }
- ;
- priority : '@' INT
- { priority($2); mpz_clear($2); }
- | '@' OP3 INT
- { if ($2 != ADDOP) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else {
- priority($3); mpz_clear($3);
- }
- }
- | '@' '-' INT
- { mpz_neg($3,$3);
- priority($3); mpz_clear($3); }
- ;
- declaration : prefix
- { type = 0; }
- headers ';'
- | TYPE xxxqtid type_alias ';'
- { if ($2 == NONE)
- ;
- else if (!(symtb[$2].flags&DCL)) {
- yyerror(qcmsg[AS_DCL_ERROR]);
- YYERROR;
- } else
- astype($2, $3, flags); }
- | scope TYPE xxxqtid type_alias ';'
- { if ($3 == NONE)
- ;
- else if (!(symtb[$3].flags&DCL)) {
- yyerror(qcmsg[AS_DCL_ERROR]);
- YYERROR;
- } else
- astype($3, $4, flags); }
- | TYPE ntid EQUIV tid ';'
- { if (checktype($4) != NONE &&
- (symtb[$4].flags&DCL))
- astype($4, $2, flags); }
- | scope TYPE ntid EQUIV tid ';'
- { if (checktype($5) != NONE &&
- (symtb[$5].flags&DCL))
- astype($5, $3, flags); }
- | TYPE ntid opt_type
- { type = dcltype($2, $3, flags);
- sflags = flags; fno_min = symtbsz; }
- opt_header_sects ';'
- { /* check for enumeration type */
- int enumtype = 1, i;
- fno_max = symtbsz-1;
- for (i = fno_min; i <= fno_max; i++)
- if (!(symtb[i].flags & CST) ||
- (symtb[i].flags & VIRT) ||
- symtb[i].argc > 0) {
- enumtype = 0; break;
- }
- if (enumtype && type) {
- symtb[type].fno_min = fno_min;
- symtb[type].fno_max = fno_max;
- }
- }
- | scope TYPE ntid opt_type
- { type = dcltype($3, $4, flags);
- sflags = flags; fno_min = symtbsz; }
- opt_header_sects ';'
- { int enumtype = 1, i;
- fno_max = symtbsz-1;
- for (i = fno_min; i <= fno_max; i++)
- if (!(symtb[i].flags & CST) ||
- (symtb[i].flags & VIRT) ||
- symtb[i].argc > 0) {
- enumtype = 0; break;
- }
- if (enumtype && type) {
- symtb[type].fno_min = fno_min;
- symtb[type].fno_max = fno_max;
- }
- }
- | EXTERN TYPE ntid opt_type
- { type = dcltype($3, $4, flags|EXT);
- sflags = flags; }
- opt_header_sects ';'
- | scope EXTERN TYPE ntid opt_type
- { type = dcltype($4, $5, flags|EXT);
- sflags = flags; }
- opt_header_sects ';'
- ;
- type_alias : /* empty */
- { $$ = 0; }
- | AS ntid
- { $$ = $2; }
- ;
- opt_type : /* empty */
- { $$ = 0; }
- | ':' tid
- { $$ = checktype($2); }
- ;
- opt_header_sects: /* empty */
- | '=' header_sects
- ;
-
- header_sects : header_sect
- | header_sects '|' header_sect
- ;
- header_sect : { flags = sflags; }
- opt_prefix headers
- ;
-
- prefix : scope
- | modifiers
- | scope modifiers
- ;
-
- opt_prefix : /* empty */
- | prefix
- ;
-
- scope : PRIVATE
- { flags = PRIV; }
- | PUBLIC
- { flags = 0; }
- ;
-
- modifiers : modifier
- | modifiers modifier
- ;
- modifier : CONST
- { flags |= CST; }
- | SPECIAL
- { flags |= SPEC; }
- | EXTERN
- { flags |= EXT; }
- | VAR
- { flags |= VSYM; }
- | VIRTUAL
- { flags |= VIRT; }
- ;
-
- headers : header
- | headers ',' { argv = 0; } header
- ;
- header : nid '=' { if ($1 == NONE)
- YYERROR;
- else if ((symtb[$1].flags & DCL) &&
- symtb[$1].modno == modno &&
- (symtb[$1].flags & VSYM) !=
- (flags & VSYM)) {
- char msg[MAXSTRLEN];
- sprintf(msg, qcmsg[MISM_DCL],
- utf8_to_sys(strsp+symtb[$1].pname));
- yyerror(msg);
- YYERROR;
- } else if (!(flags & VSYM) || type ||
- (flags & (EXT|SPEC|VIRT))) {
- yyerror(qcmsg[DCL_ERROR]);
- YYERROR;
- } else {
- int vno = dclfvar($1, flags);
- init_def(); $<xval>$ = funexpr(vno);
- debug_info();
- }
- }
- expression0
- { definition($<xval>3, $4); }
- | nid vid_list
- { if ($1 == NONE)
- ;
- else if ((symtb[$1].flags & DCL) &&
- symtb[$1].modno == modno &&
- (symtb[$1].flags & VSYM) !=
- (flags & VSYM)) {
- char msg[MAXSTRLEN];
- sprintf(msg, qcmsg[MISM_DCL],
- utf8_to_sys(strsp+symtb[$1].pname));
- yyerror(msg);
- YYERROR;
- } else if ((flags & VSYM) && ($2 || type) ||
- (flags & VSYM) &&
- (flags & (EXT|SPEC|VIRT)) ||
- (flags & CST) && (flags & EXT) ||
- type &&
- (symtb[type].flags & EXT) &&
- !(flags & VIRT) ||
- !(flags & VSYM) &&
- isvsym(strsp+symtb[$1].pname)) {
- yyerror(qcmsg[DCL_ERROR]);
- YYERROR;
- } else if (flags & VSYM)
- dclfvar($1, flags);
- else
- dclfun($1, type, $2, argv, flags, NONE); }
- | '(' cccnfid ')' vid_list op_prec
- { int prec = $5;
- if (prec == NONE && $2 != NONE &&
- symtb[$2].modno == modno)
- prec = symtb[$2].prec;
- if (prec == NONE) prec = 2;
- if ($2 == NONE)
- ;
- else if ((flags & VSYM) ||
- (flags & CST) && (flags & EXT) ||
- type && (symtb[type].flags & EXT) &&
- !(flags & VIRT) ||
- (prec == 5 || prec == 9) && $4 != 1 ||
- (prec != 5 && prec != 9) && $4 != 2) {
- yyerror(qcmsg[DCL_ERROR]);
- YYERROR;
- } else
- dclfun($2, type, $4, argv, flags, prec); }
- | xxxqid vid_list id_alias
- { int sym = $1; $1 = xxxsym($1);
- if ($1 == NONE)
- ;
- else if (!(symtb[$1].flags&DCL)) {
- yyerror(qcmsg[AS_DCL_ERROR]);
- YYERROR;
- } else if ((symtb[$1].flags & DCL) &&
- (symtb[$1].flags & VSYM) !=
- (flags & VSYM)) {
- char msg[MAXSTRLEN];
- sprintf(msg, qcmsg[MISM_DCL],
- utf8_to_sys(strsp+symtb[$1].pname));
- yyerror(msg);
- YYERROR;
- } else if ((flags & VSYM) && ($2 || type) ||
- (flags & VSYM) && (flags & (EXT|SPEC|VIRT)) ||
- (flags & CST) && (flags & EXT) ||
- !(flags & VSYM) &&
- isvsym(strsp+symtb[$1].pname) ||
- type ||
- $3 && symtb[$3].modno == modno &&
- (symtb[$3].flags&DCL)) {
- yyerror(qcmsg[DCL_ERROR]);
- YYERROR;
- } else if (flags & VSYM)
- asfvar(sym, $3, flags);
- else
- asfun(sym, $3, $2, argv, flags, NONE); }
- | '(' xxxqfid_or_op ')' vid_list op_prec op_alias
- { int sym = $2; $2 = xxxsym($2);
- int prec = $5;
- if (prec == NONE && $2 != NONE)
- prec = symtb[$2].prec;
- if ($2 == NONE)
- ;
- else if (!(symtb[$2].flags&DCL)) {
- yyerror(qcmsg[AS_DCL_ERROR]);
- YYERROR;
- } else if ((flags & VSYM) ||
- (flags & CST) && (flags & EXT) ||
- type ||
- $6 && symtb[$6].modno == modno &&
- (symtb[$6].flags&DCL) ||
- prec == NONE ||
- (prec == 5 || prec == 9) && $4 != 1 ||
- (prec != 5 && prec != 9) && $4 != 2) {
- yyerror(qcmsg[DCL_ERROR]);
- YYERROR;
- } else
- asfun(sym, $6, $4, argv, flags, prec); }
- ;
- vid_list : /* empty */
- { $$ = 0; }
- | vid_list UID
- { if (flags & SPEC)
- if ($1 < sizeof(unsigned long)*8)
- argv |= 1<<$1;
- else {
- yyerror(qcmsg[DCL_ERROR]);
- YYERROR;
- }
- $$ = $1+1; }
- | vid_list '~' UID
- { if (!(flags & SPEC)) {
- yyerror(qcmsg[DCL_ERROR]);
- YYERROR;
- }
- $$ = $1+1; }
- ;
- op_prec : /* empty */
- { $$ = NONE; }
- | '@' INT
- { $$ = precval($2); }
- | '@' '(' op ')'
- { int prec = symtb[$3].prec;
- if (prec >= 0 && prec <= 9 && prec != 8)
- $$ = prec;
- else {
- yyerror(qcmsg[INVALID_PREC]);
- $$ = NONE;
- }
- }
- ;
- id_alias : /* empty */
- { $$ = 0; }
- | AS nid
- { $$ = $2; }
- ;
- op_alias : /* empty */
- { $$ = 0; }
- | AS cccnid
- { $$ = $2; }
- ;
- definition : DEF defs ';'
- | UNDEF undefs ';'
- ;
- defs : def
- | defs ',' def
- ;
- def : { init_def(); }
- lexpression0 '='
- { debug_info(); }
- expression0
- { definition($2, $5); }
- ;
- undefs : undef
- | undefs ',' undef
- ;
- undef : id
- { if ($1 != NONE) {
- init_def();
- if (!(symtb[$1].flags & VSYM))
- yyerror(qcmsg[INVALID_DEF]);
- else {
- symtb[$1].flags |= DCL;
- debug_info();
- definition(funexpr($1), NULL);
- }
- }
- }
- ;
- rule : lexpression0
- { debug_info(); left_hand_side($1);
- start_qualifiers(); }
- body
- { end_rule(); }
- ;
- body : opt_qualifiers '='
- { begin_rule(); start_qualifiers(); }
- expression0 qualifiers ';'
- { qualifiers(); right_hand_side($4);
- start_qualifiers(); }
- | body { qualtest = 1; }
- opt_qualifiers2 '='
- { qualtest = 0;
- begin_rule(); start_qualifiers(); }
- expression0 qualifiers ';'
- { qualifiers(); right_hand_side($6);
- start_qualifiers(); }
- ;
- opt_qualifiers : /* empty */
- { mark(); }
- | lqualifiers ':'
- { qualifiers(); mark(); }
- ;
- opt_qualifiers2 : /* empty */
- | lqualifiers ':'
- { qualifiers(); mark(); }
- ;
- lqualifiers : lqualifier
- | lqualifiers lqualifier
- lqualifier : condition
- { add_qualifier($1); }
- | where
- ;
- qualifiers : /* empty */
- | qualifiers condition
- { add_qualifier($2); }
- | qualifiers where
- ;
- condition : IF { if (qualtest) qualtest = 0,
- same_left_hand_side(); }
- expression
- { $$ = $3; }
- | OTHERWISE
- { if (qualtest) qualtest = 0,
- same_left_hand_side();
- $$ = NULL; }
- ;
- where : WHERE
- { if (qualtest) qualtest = 0,
- same_left_hand_side();
- start_where_clauses(); }
- where_clauses
- { end_where_clauses(); }
- ;
- where_clauses : where_clause
- | where_clauses ',' where_clause
- ;
- where_clause : lexpression0 '=' expression0
- { add_where_clause($1, $3); }
- ;
- /* top-level expressions (= operator and if-then-else not permitted here) */
- lexpression0 : lsequence0
- | '\\' llambda0 { $$ = $2; }
- ;
- llambda0 : lprimary '.' lexpression0
- { $$ = binexpr(LAMBDAOP, $1, $3); }
- | lprimary llambda0
- { $$ = binexpr(LAMBDAOP, $1, $2); }
- ;
- lsequence0 : lcond0
- | lsequence0 seqop lcond0
- { $$ = binexpr($2, $1, $3); }
- ;
- lcond0 : lrightapp0
- /* Q 7.7: eliminated lhs toplevel if-then-else construct to resolve syntactic
- ambiguity with left-hand guards
- | IF lrightapp THEN lcond0 ELSE lcond0
- { static char sym[20];
- int fno = getfun(strcpy(sym, "cond::ifelse"));
- if (fno == NONE) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = ternexpr(fno, $2, $4, $6); }
- | IF lrightapp THEN lcond0
- { static char sym[20];
- int fno = getfun(strcpy(sym, "cond::when"));
- if (fno == NONE) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = binexpr(fno, $2, $4); }
- */
- ;
- lrightapp0 : lrelation0
- | lrelation0 rappop lrightapp0
- { $$ = binexpr($2, $1, $3); }
- ;
- lrelation0 : laddition
- | laddition relop0 laddition
- { $$ = binexpr($2, $1, $3); }
- ;
- expression0 : sequence0
- | '\\' lambda0 { $$ = $2; }
- ;
- lambda0 : primary '.' expression0
- { $$ = binexpr(LAMBDAOP, $1, $3); }
- | primary lambda0
- { $$ = binexpr(LAMBDAOP, $1, $2); }
- ;
- sequence0 : cond0
- | sequence0 seqop cond0
- { $$ = binexpr($2, $1, $3); }
- ;
- cond0 : rightapp0
- | IF rightapp THEN cond0 ELSE cond0
- { static char sym[20];
- int fno = getfun(strcpy(sym, "cond::ifelse"));
- if (fno == NONE) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = ternexpr(fno, $2, $4, $6); }
- | IF rightapp THEN cond0
- { static char sym[20];
- int fno = getfun(strcpy(sym, "cond::when"));
- if (fno == NONE) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = binexpr(fno, $2, $4); }
- ;
- rightapp0 : relation0
- | relation0 rappop rightapp0
- { $$ = binexpr($2, $1, $3); }
- ;
- relation0 : addition
- | addition relop0 addition
- { $$ = binexpr($2, $1, $3); }
- ;
- relop0 : EQUIV { $$ = IDOP; }
- | OP2
- ;
- /* These are duplicated from below to keep track of whether we're in the lhs
- of a definition. */
- lexpression : lsequence
- | '\\' llambda { $$ = $2; }
- ;
- llambda : lprimary '.' lexpression
- { $$ = binexpr(LAMBDAOP, $1, $3); }
- | lprimary llambda
- { $$ = binexpr(LAMBDAOP, $1, $2); }
- ;
- lsequence : lcond
- | lsequence seqop lcond
- { $$ = binexpr($2, $1, $3); }
- ;
- lcond : lrightapp
- | IF lrightapp THEN lcond ELSE lcond
- { static char sym[20];
- int fno = getfun(strcpy(sym, "cond::ifelse"));
- if (fno == NONE) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = ternexpr(fno, $2, $4, $6); }
- | IF lrightapp THEN lcond
- { static char sym[20];
- int fno = getfun(strcpy(sym, "cond::when"));
- if (fno == NONE) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = binexpr(fno, $2, $4); }
- ;
- lrightapp : lrelation
- | lrelation rappop lrightapp
- { $$ = binexpr($2, $1, $3); }
- ;
- lrelation : laddition
- | laddition relop laddition
- { $$ = binexpr($2, $1, $3); }
- ;
- laddition : lmultiplication
- | laddition addop lmultiplication
- { $$ = binexpr($2, $1, $3); }
- | laddition '-' lmultiplication
- { $$ = binexpr(MINOP, $1, $3); }
- ;
- lmultiplication : lunary
- | lmultiplication mulop lunary
- { $$ = binexpr($2, $1, $3); }
- ;
- /* ! ambiguous rule */
- lunary : lscript
- | '-' INT { mpz_neg($2, $2); $$ = intexpr($2); }
- | '-' FLOAT { $$ = floatexpr(-$2); }
- | '-' lunary { $$ = unexpr(UMINOP, $2); }
- | unop lunary { $$ = unexpr($1, $2); }
- lscript : lcomposition
- | lcomposition scriptop lscript
- { $$ = binexpr($2, $1, $3); }
- ;
- lcomposition : lapplication
- | lcomposition compop lapplication
- { $$ = binexpr($2, $1, $3); }
- ;
- lapplication : lprimary
- | lapplication lprimary
- { $$ = appexpr($1, $2); }
- ;
- expression : sequence
- | '\\' lambda { $$ = $2; }
- ;
- lambda : primary '.' expression
- { $$ = binexpr(LAMBDAOP, $1, $3); }
- | primary lambda
- { $$ = binexpr(LAMBDAOP, $1, $2); }
- ;
- sequence : cond
- | sequence seqop cond
- { $$ = binexpr($2, $1, $3); }
- ;
- seqop : OP0
- ;
- cond : rightapp
- | IF rightapp THEN cond ELSE cond
- { static char sym[20];
- int fno = getfun(strcpy(sym, "cond::ifelse"));
- if (fno == NONE) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = ternexpr(fno, $2, $4, $6); }
- | IF rightapp THEN cond
- { static char sym[20];
- int fno = getfun(strcpy(sym, "cond::when"));
- if (fno == NONE) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = binexpr(fno, $2, $4); }
- ;
- rightapp : relation
- | relation rappop rightapp
- { $$ = binexpr($2, $1, $3); }
- ;
- rappop : OP1
- ;
- relation : addition
- | addition relop addition
- { $$ = binexpr($2, $1, $3); }
- ;
- relop : '=' { $$ = EQOP; }
- | EQUIV { $$ = IDOP; }
- | OP2
- ;
- addition : multiplication
- | addition addop multiplication
- { $$ = binexpr($2, $1, $3); }
- | addition '-' multiplication
- { $$ = binexpr(MINOP, $1, $3); }
- ;
- addop : OP3 ELSE { if ($1 != OROP) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = ORELSEOP; }
- | OP3
- ;
- multiplication : unary
- | multiplication mulop unary
- { $$ = binexpr($2, $1, $3); }
- ;
- mulop : OP4 THEN { if ($1 != ANDOP) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = ANDTHENOP; }
- | OP4
- ;
- /* ! ambiguous rule */
- unary : script
- | '-' INT { mpz_neg($2, $2); $$ = intexpr($2); }
- | '-' FLOAT { $$ = floatexpr(-$2); }
- | '-' unary { $$ = unexpr(UMINOP, $2); }
- | unop unary { $$ = unexpr($1, $2); }
- ;
- unop : OP5
- ;
- script : composition
- | composition scriptop script
- { $$ = binexpr($2, $1, $3); }
- ;
- scriptop : OP6
- ;
- composition : application
- | composition compop application
- { $$ = binexpr($2, $1, $3); }
- ;
- compop : '.' { $$ = COMPOP; }
- | OP7
- ;
- application : primary
- | application primary
- { $$ = appexpr($1, $2); }
- ;
- quoteop : '~' { $$ = FORCEOP; }
- | OP9
- ;
- /* type guards are only permitted in lhs expressions */
- lprimary : atom
- | vid ':' tid { checktype($3); vartb[$1].type = $3;
- $$ = varexpr($1); }
- /* quoted expressions */
-
- | quoteop lprimary
- { $$ = unexpr($1, $2); }
- /* sections: */
- | '(' lsequence seqop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' seqop lrightapp ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' lrelation rappop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' rappop lrightapp ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' laddition relop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' relop laddition ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' laddition addop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' laddition '-' ')'
- { $$ = appexpr(funexpr(MINOP), $2); }
- | '(' addop lmultiplication ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' lmultiplication mulop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' mulop lunary ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' lcomposition scriptop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' scriptop lscript ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' lcomposition compop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' compop lapplication ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- /* parenthesized expressions and tuples: */
- | '(' ')'
- { $$ = funexpr(VOIDOP); }
- | '(' lexpression ')'
- { $$ = $2; }
- | '(' lexpression ',' ')'
- { $$ = pairexpr($2, funexpr(VOIDOP)); }
- | '(' lexpression ';' ')'
- { $$ = pairexpr(pairexpr($2, funexpr(VOIDOP)),
- funexpr(VOIDOP)); }
- | '(' lexpression '|' lexpression ')'
- { $$ = pairexpr($2, $4); }
- | '(' lexpression DOTDOT lexpression ')'
- { $$ = appexpr(appexpr(funexpr(TENUMOP),
- listexpr(addexpr(addexpr(exprlist(), $2),
- funexpr(NILOP)))),
- $4); }
- | '(' lexpression DOTDOT ')'
- { $$ = appexpr(funexpr(TENUM1OP),
- listexpr(addexpr(addexpr(exprlist(), $2),
- funexpr(NILOP)))); }
- | '(' lexpression ',' lexpr_list1 ')'
- { $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' lexpression ',' lexpr_list1 ',' ')'
- { $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' lexpression ',' lexpr_list1 ';' ')'
- { if ($4->m < 0) $4->m = 0;
- $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' lexpression ',' lexpr_list1 '|' lexpression ')'
- { $$ = tupleexpr(addexpr($4, $6)); }
- | '(' lexpression ',' lexpr_list1 DOTDOT lexpression ')'
- { $$ = appexpr(appexpr(funexpr(TENUMOP),
- listexpr(addexpr($4, funexpr(NILOP)))),
- $6); }
- | '(' lexpression ',' lexpr_list1 DOTDOT ')'
- { $$ = appexpr(funexpr(TENUM1OP),
- listexpr(addexpr($4, funexpr(NILOP)))); }
- /* handle the special case of a group of size 1 at the beginning of the
- tuple */
- | '(' lexpression ';' lexpr_list2 ')'
- { $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' lexpression ';' lexpr_list2 ',' ')'
- { $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' lexpression ';' lexpr_list2 ';' ')'
- { if ($4->m < 0) $4->m = 0;
- $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' lexpression ';' lexpr_list2 '|' lexpression ')'
- { $$ = tupleexpr(addexpr($4, $6)); }
- /* lists: */
- | '[' ']'
- { $$ = funexpr(NILOP); }
- | '[' lexpr_list ']'
- { $$ = listexpr(
- addexpr($2, funexpr(NILOP))); }
- | '[' lexpr_list ',' ']'
- { $$ = listexpr(
- addexpr($2, funexpr(NILOP))); }
- | '[' lexpr_list ';' ']'
- { if ($2->m < 0) $2->m = 0;
- $$ = listexpr(
- addexpr($2, funexpr(NILOP))); }
- | '[' lexpr_list '|' lexpression ']'
- { $$ = listexpr(addexpr($2, $4)); }
- | '[' lexpr_list DOTDOT lexpression ']'
- { $$ = appexpr(appexpr(funexpr(ENUMOP),
- listexpr(addexpr($2, funexpr(NILOP)))),
- $4); }
- | '[' lexpr_list DOTDOT ']'
- { $$ = appexpr(funexpr(ENUM1OP),
- listexpr(addexpr($2, funexpr(NILOP)))); }
- /* streams: */
- | '{' '}'
- { $$ = funexpr(SNILOP); }
- | '{' lexpr_list '}'
- { $$ = streamexpr(
- addexpr($2, funexpr(SNILOP))); }
- | '{' lexpr_list ',' '}'
- { $$ = streamexpr(
- addexpr($2, funexpr(SNILOP))); }
- | '{' lexpr_list ';' '}'
- { if ($2->m < 0) $2->m = 0;
- $$ = streamexpr(
- addexpr($2, funexpr(SNILOP))); }
- | '{' lexpr_list '|' lexpression '}'
- { $$ = streamexpr(addexpr($2, $4)); }
- | '{' lexpr_list DOTDOT lexpression '}'
- { $$ = appexpr(appexpr(funexpr(SENUMOP),
- listexpr(addexpr($2, funexpr(NILOP)))),
- $4); }
- | '{' lexpr_list DOTDOT '}'
- { $$ = appexpr(funexpr(SENUM1OP),
- listexpr(addexpr($2, funexpr(NILOP)))); }
- ;
- /* inline var declarations and list/stream comprehensions are only permitted
- on the rhs of definitions */
- primary : atom
- /* inline var declaration */
- | VAR nid { int vno = $2;
- if (!(symtb[vno].flags&DCL) ||
- symtb[vno].modno != modno ||
- !(symtb[vno].flags&VSYM))
- vno = dclfvar(vno, PRIV|VSYM);
- $$ = funexpr(vno); }
- /* quoted expressions */
-
- | quoteop primary
- { $$ = unexpr($1, $2); }
- /* sections: */
- | '(' sequence seqop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' seqop rightapp ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' relation rappop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' rappop rightapp ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' addition relop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' relop addition ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' addition addop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' addition '-' ')'
- { $$ = appexpr(funexpr(MINOP), $2); }
- | '(' addop multiplication ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' multiplication mulop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' mulop unary ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' composition scriptop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' scriptop script ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- | '(' composition compop ')'
- { $$ = appexpr(funexpr($3), $2); }
- | '(' compop application ')'
- { $$ = appexpr(appexpr(funexpr(FLIPOP),
- funexpr($2)),
- $3); }
- /* parenthesized expressions and tuples: */
- | '(' ')'
- { $$ = funexpr(VOIDOP); }
- | '(' expression ')'
- { $$ = $2; }
- | '(' expression ',' ')'
- { $$ = pairexpr($2, funexpr(VOIDOP)); }
- | '(' expression ';' ')'
- { $$ = pairexpr(pairexpr($2, funexpr(VOIDOP)),
- funexpr(VOIDOP)); }
- | '(' expression '|' expression ')'
- { $$ = pairexpr($2, $4); }
- | '(' expression DOTDOT expression ')'
- { $$ = appexpr(appexpr(funexpr(TENUMOP),
- listexpr(addexpr(addexpr(exprlist(), $2),
- funexpr(NILOP)))),
- $4); }
- | '(' expression DOTDOT ')'
- { $$ = appexpr(funexpr(TENUM1OP),
- listexpr(addexpr(addexpr(exprlist(), $2),
- funexpr(NILOP)))); }
- | '(' expression ',' expr_list1 ')'
- { $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' expression ',' expr_list1 ',' ')'
- { $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' expression ',' expr_list1 ';' ')'
- { if ($4->m < 0) $4->m = 0;
- $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' expression ',' expr_list1 '|' expression ')'
- { $$ = tupleexpr(addexpr($4, $6)); }
- | '(' expression ',' expr_list1 DOTDOT expression ')'
- { $$ = appexpr(appexpr(funexpr(TENUMOP),
- listexpr(addexpr($4, funexpr(NILOP)))),
- $6); }
- | '(' expression ',' expr_list1 DOTDOT ')'
- { $$ = appexpr(funexpr(TENUM1OP),
- listexpr(addexpr($4, funexpr(NILOP)))); }
- | '(' expression ':'
- { static char sym[20];
- int fno = getfun(strcpy(sym, "cond::tupleof"));
- if (fno == NONE) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $<ival>$ = fno; }
- expr_list ')'
- { $$ = appexpr(appexpr(funexpr($<ival>4), $2),
- tupleexpr(addexpr($5, funexpr(VOIDOP)))); }
- /* handle the special case of a group of size 1 at the beginning of the
- tuple */
- | '(' expression ';' expr_list2 ')'
- { $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' expression ';' expr_list2 ',' ')'
- { $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' expression ';' expr_list2 ';' ')'
- { if ($4->m < 0) $4->m = 0;
- $$ = tupleexpr(addexpr($4, funexpr(VOIDOP))); }
- | '(' expression ';' expr_list2 '|' expression ')'
- { $$ = tupleexpr(addexpr($4, $6)); }
- /* lists: */
- | '[' ']'
- { $$ = funexpr(NILOP); }
- | '[' expr_list ']'
- { $$ = listexpr(
- addexpr($2, funexpr(NILOP))); }
- | '[' expr_list ',' ']'
- { $$ = listexpr(
- addexpr($2, funexpr(NILOP))); }
- | '[' expr_list ';' ']'
- { if ($2->m < 0) $2->m = 0;
- $$ = listexpr(
- addexpr($2, funexpr(NILOP))); }
- | '[' expr_list '|' expression ']'
- { $$ = listexpr(addexpr($2, $4)); }
- | '[' expr_list DOTDOT expression ']'
- { $$ = appexpr(appexpr(funexpr(ENUMOP),
- listexpr(addexpr($2, funexpr(NILOP)))),
- $4); }
- | '[' expr_list DOTDOT ']'
- { $$ = appexpr(funexpr(ENUM1OP),
- listexpr(addexpr($2, funexpr(NILOP)))); }
- | '[' expression ':'
- { static char sym[20];
- int fno = getfun(strcpy(sym, "cond::listof"));
- if (fno == NONE) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $<ival>$ = fno; }
- expr_list ']'
- { $$ = appexpr(appexpr(funexpr($<ival>4), $2),
- tupleexpr(addexpr($5, funexpr(VOIDOP)))); }
- /* streams: */
- | '{' '}'
- { $$ = funexpr(SNILOP); }
- | '{' expr_list '}'
- { $$ = streamexpr(
- addexpr($2, funexpr(SNILOP))); }
- | '{' expr_list ',' '}'
- { $$ = streamexpr(
- addexpr($2, funexpr(SNILOP))); }
- | '{' expr_list ';' '}'
- { if ($2->m < 0) $2->m = 0;
- $$ = streamexpr(
- addexpr($2, funexpr(SNILOP))); }
- | '{' expr_list '|' expression '}'
- { $$ = streamexpr(addexpr($2, $4)); }
- | '{' expr_list DOTDOT expression '}'
- { $$ = appexpr(appexpr(funexpr(SENUMOP),
- listexpr(addexpr($2, funexpr(NILOP)))),
- $4); }
- | '{' expr_list DOTDOT '}'
- { $$ = appexpr(funexpr(SENUM1OP),
- listexpr(addexpr($2, funexpr(NILOP)))); }
- | '{' expression ':'
- { static char sym[20];
- int fno = getfun(strcpy(sym, "cond::streamof"));
- if (fno == NONE) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $<ival>$ = fno; }
- expr_list '}'
- { $$ = appexpr(appexpr(funexpr($<ival>4), $2),
- tupleexpr(addexpr($5, funexpr(VOIDOP)))); }
- ;
- /* atomic expressions (permitted on either side of a definition) */
- atom
- /* constants: */
- : INT { $$ = intexpr($1); }
- | FLOAT { $$ = floatexpr($1); }
- | STR { $$ = strexpr($1); }
- /* variable and function symbols: */
- | '(' op ')' { $$ = funexpr($2); }
- | fid { $$ = funexpr($1); }
- | qvid { $$ = funexpr($1); }
- | vid { vartb[$1].type = 0;
- $$ = varexpr($1); }
- ;
- lexpr_list1 : lexpression
- { $$ = addexpr(addexpr(exprlist(), $<xval>-1),
- $1); }
- | lexpr_list1 ',' lexpression
- { $$ = addexpr($1, $3); }
- | lexpr_list1 ';' lexpression
- { $$ = groupexpr(addexpr($1, $3)); }
- ;
- lexpr_list2 : lexpression
- { $$ = groupexpr(addexpr(addexpr(exprlist(),
- $<xval>-1),
- $1)); }
- | lexpr_list2 ',' lexpression
- { $$ = addexpr($1, $3); }
- | lexpr_list2 ';' lexpression
- { $$ = groupexpr(addexpr($1, $3)); }
- ;
- lexpr_list : lexpression
- { $$ = addexpr(exprlist(), $1); }
- | lexpr_list ',' lexpression
- { $$ = addexpr($1, $3); }
- | lexpr_list ';' lexpression
- { $$ = groupexpr(addexpr($1, $3)); }
- ;
- expr_list1 : expression
- { $$ = addexpr(addexpr(exprlist(), $<xval>-1),
- $1); }
- | expr_list1 ',' expression
- { $$ = addexpr($1, $3); }
- | expr_list1 ';' expression
- { $$ = groupexpr(addexpr($1, $3)); }
- ;
- expr_list2 : expression
- { $$ = groupexpr(addexpr(addexpr(exprlist(),
- $<xval>-1),
- $1)); }
- | expr_list2 ',' expression
- { $$ = addexpr($1, $3); }
- | expr_list2 ';' expression
- { $$ = groupexpr(addexpr($1, $3)); }
- ;
- expr_list : expression
- { $$ = addexpr(exprlist(), $1); }
- | expr_list ',' expression
- { $$ = addexpr($1, $3); }
- | expr_list ';' expression
- { $$ = groupexpr(addexpr($1, $3)); }
- ;
- builtin_op : '=' { $$ = EQOP; }
- | EQUIV { $$ = IDOP; }
- | '-' { $$ = MINOP; }
- | '~' { $$ = FORCEOP; }
- | '.' { $$ = COMPOP; }
- ;
- op : builtin_op
- | OP3 ELSE { if ($1 != OROP) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = ORELSEOP; }
- | OP4 THEN { if ($1 != ANDOP) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = ANDTHENOP; }
- | OP0
- | OP1
- | OP2
- | OP3
- | OP4
- | OP5
- | OP6
- | OP7
- | OP9
- ;
- id : fid
- | fvid
- ;
- nid : nfid
- | nfvid
- ;
- fid : LID
- { $$ = mkfun($1); }
- | QLID
- { $$ = mkfun($1); }
- ;
- nfid : LID
- { $$ = mkxfun($1); }
- ;
- vid : UID
- { $$ = mkvar($1); }
- ;
- fvid : UID
- { $$ = mkfvar($1); }
- | QUID
- { $$ = mkfvar($1); }
- ;
- nfvid : UID
- { $$ = mkxfvar($1); }
- ;
- qvid : QUID
- { $$ = mkfvar($1); }
- ;
- /* These need a special parsing context (declarations). */
- c_on : { context = 1; }
- ;
- c_off : { context = 0; }
- ;
- cccnid : c_on nid c_off
- { $$ = $2; }
- ;
- cccnfid : c_on nfid c_off
- { $$ = $2; }
- ;
- tid : c_on UID c_off
- { $$ = mktype($2); }
- | c_on LID c_off
- { $$ = mktype($2); }
- | c_on QUID c_off
- { $$ = mktype($2); }
- | c_on QLID c_off
- { $$ = mktype($2); }
- ;
- ntid : c_on UID c_off
- { $$ = mkxtype($2); }
- | c_on LID c_off
- { $$ = mkxtype($2); }
- ;
- /* These also need special treatment (qualified symbols in alias
- declarations). CAUTION: These symbols are returned unnormalized! */
- xxxqid : xxxqfid
- | xxxqfvid
- ;
- xxxqfid : QLID
- { $$ = mkxxxfun($1); }
- ;
- xxxqfvid : QUID
- { $$ = mkxxxfvar($1); }
- ;
- xxxqfid_or_op : c_on xxxqfid_or_op2 c_off
- { $$ = $2; }
- ;
- /* Give the programmer a way to declare (and then) and (or else). */
- xxxqfid_or_op2 : xxxqfid ELSE { if ($1 != OROP) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = ORELSEOP; }
- | xxxqfid THEN { if ($1 != ANDOP) {
- yyerror(qcmsg[SYNTAX_ERROR]);
- YYERROR;
- } else
- $$ = ANDTHENOP; }
- | xxxqfid
- ;
- xxxqtid : c_on QUID c_off
- { $$ = mkxxxtype($2); }
- | c_on QLID c_off
- { $$ = mkxxxtype($2); }
- ;
-
- %%
- extern int yyleng, yylineno;
- extern char *source;
- yyerror(s)
- char *s;
- {
- fprintf(stderr, "Error %s, line %d: %s", source, yylineno, s);
- if (*yytext && (strcmp(s, "parse error") == 0 ||
- strcmp(s, "syntax error") == 0))
- fprintf(stderr, " at or near symbol `%s'",
- utf8_to_sys(yytext));
- fprintf(stderr, "\n");
- nerrs++;
- }
- yywarn(s)
- char *s;
- {
- if (wflag) {
- fprintf(stderr, "Warning %s, line %d: %s\n", source,
- yylineno, s);
- nwarns++;
- }
- }
- fatal(s)
- char *s;
- {
- if (source && *source)
- fprintf(stderr, "%s: %s: %s -- compilation aborted\n",
- self, source, s);
- else
- fprintf(stderr, "%s: %s -- compilation aborted\n",
- self, s);
- if (codefp) {
- fclose(codefp);
- remove(code);
- }
- exit(1);
- }
- #define no(n) n, n==1?"":"s"
- static
- statistics()
- {
- int fno, k, n, b, bmax, btotal, n_data;
- for (n = bmax = btotal = k = 0; k < hashtbsz; k++)
- if (hashtb[k] != NONE) {
- n++;
- for (b = -1, fno = hashtb[k]; fno != NONE;
- b++, fno = symtb[fno].next)
- ;
- btotal += b;
- if (b+1>bmax)
- bmax = b+1;
- }
- n_data = strspsz+limbspsz*sizeof(mp_limb_t);
- printf("%d ops in %d module%s, ", codespsz, no(modtbsz));
- printf("%d byte%s data, ", no(n_data));
- printf("%d symbol%s,\n", no(symtbsz));
- printf("%d hash key%s out of %d, %d collision%s, max bucket size = %d\n",
- no(n), hashtbsz, no(btotal), bmax);
- printf("%d state%s, %d transition%s, %d offset%s\n",
- no(statetbsz), no(transtbsz), no(roffstbsz));
- }
- static void *
- gmp_allocate (size)
- size_t size;
- {
- void *ret;
- ret = malloc (size);
- if (ret == 0) fatal(qcmsg[MEM_OVF]);
- return ret;
- }
- static void *
- gmp_reallocate (oldptr, old_size, new_size)
- void *oldptr;
- size_t old_size;
- size_t new_size;
- {
- void *ret;
- ret = realloc (oldptr, new_size);
- if (ret == 0) fatal(qcmsg[MEM_OVF]);
- return ret;
- }
- static void
- gmp_free (blk_ptr, blk_size)
- void *blk_ptr;
- size_t blk_size;
- {
- free (blk_ptr);
- }
- #ifdef HAVE_UNICODE
- static inline long
- u8decode(char *s)
- {
- size_t n;
- unsigned p = 0, q = 0;
- unsigned long c = 0;
- if (s[0] == 0)
- return -1;
- else if (s[1] == 0)
- return (unsigned char)s[0];
- for (n = 0; n == 0 && *s; s++) {
- unsigned char uc = (unsigned char)*s;
- if (q == 0) {
- if (((signed char)*s) < 0) {
- switch (uc & 0xf0) {
- case 0xc0: case 0xd0:
- q = 1;
- c = uc & 0x1f;
- break;
- case 0xe0:
- q = 2;
- c = uc & 0xf;
- break;
- case 0xf0:
- if ((uc & 0x8) == 0) {
- q = 3;
- c = uc & 0x7;
- } else
- c = uc;
- break;
- default:
- c = uc;
- break;
- }
- } else
- c = uc;
- p = 0;
- if (q == 0) n++;
- } else if ((uc & 0xc0) == 0x80) {
- /* continuation byte */
- c = c << 6 | (uc & 0x3f);
- if (--q == 0)
- n++;
- else
- p++;
- } else {
- /* malformed char */
- return -1;
- }
- }
- if (n == 1 && *s == 0)
- return c;
- else
- return -1;
- }
- #endif
- static int isvsym(char *s)
- {
- if (!*s)
- return 0;
- else {
- #ifdef HAVE_UNICODE
- long c = u8decode(s);
- if (c < 0) c = (unsigned char)*s;
- return u_isupper(c);
- #else
- return isupper(s[0]);
- #endif
- }
- }
- RETSIGTYPE
- break_handler()
- /* handle SIGINT and SIGTERM */
- {
- /* Since many system functions are unsave to call in a signal
- handler, we simply set a flag here; the corresponding actions
- in response to SIGINT (remove code file, close list file,
- terminate program) will be carried out later in a save
- context. */
- int_sig = 1;
- SIGHANDLER_RETURN(0);
- }
- checkint()
- /* check for pending int_sig */
- {
- if (int_sig) fatal("interrupt");
- }
- newrule()
- /* reinitialize for the next rule */
- {
- clear(); qualtest = 0; checkint();
- }
- newdecl()
- /* reinitialize for the next declaration */
- {
- flags = PRIV; argv = 0; checkint();
- }
- precval(z)
- mpz_t z;
- /* calculate precedence level */
- {
- if (my_mpz_fits_slong_p(z)) {
- long prec = mpz_get_si(z);
- if (prec >= 0 && prec <= 9 && prec != 8)
- return prec;
- }
- yyerror(qcmsg[INVALID_PREC]);
- return NONE;
- }
- priority(z)
- mpz_t z;
- /* set a new priority level */
- {
- if (my_mpz_fits_slong_p(z))
- prio = mpz_get_si(z);
- else
- yyerror(qcmsg[INVALID_PRIO]);
- }
- /* qualifier table */
- int qual_size, qual_alloc, clause_size, clause_alloc;
- static QUAL *qual;
- static CLAUSE *clause;
- static void start_qualifiers(void)
- {
- qual_size = clause_size = 0;
- }
- static void qualifiers(void)
- {
- int i;
- for (i = qual_size-1; i >= 0; i--)
- if (qual[i].x)
- qualifier(qual[i].x);
- else {
- int j;
- for (j = qual[i].start; j < qual[i].end; j++)
- where_clause(clause[j].l, clause[j].r);
- }
- }
- static void add_qualifier(EXPR *x)
- {
- if (!x) return;
- if (qual_size >= qual_alloc)
- if ((qual = arealloc(qual, qual_alloc, 10, sizeof(QUAL))))
- qual_alloc += 10;
- else
- fatal("memory overflow");
- qual[qual_size++].x = x;
- }
- static void start_where_clauses(void)
- {
- if (qual_size >= qual_alloc)
- if ((qual = arealloc(qual, qual_alloc, 10, sizeof(QUAL))))
- qual_alloc += 10;
- else
- fatal("memory overflow");
- qual[qual_size].x = NULL;
- qual[qual_size].start = clause_size;
- }
- static void end_where_clauses(void)
- {
- qual[qual_size++].end = clause_size;
- }
- static void add_where_clause(EXPR *l, EXPR *r)
- {
- if (clause_size >= clause_alloc)
- if ((clause = arealloc(clause, clause_alloc, 10, sizeof(CLAUSE))))
- clause_alloc += 10;
- else
- fatal("memory overflow");
- clause[clause_size].l = l;
- clause[clause_size].r = r;
- clause_size++;
- }
- /* expression lists */
- static xvect_t *exprlist(void)
- {
- xvect_t *v = (xvect_t*)malloc(sizeof(xvect_t));
- if (!v) fatal("memory overflow");
- v->a = v->n = 0; v->m = -1;
- v->xv = NULL;
- return v;
- }
- static xvect_t *addexpr(xvect_t *v, EXPR *x)
- {
- if (v->n >= v->a) {
- v->a += 100;
- if (v->xv)
- v->xv = realloc(v->xv, v->a*sizeof(EXPR*));
- else
- v->xv = malloc(v->a*sizeof(EXPR*));
- if (!v->xv) fatal("memory overflow");
- }
- v->xv[v->n++] = x;
- return v;
- }
- static xvect_t *groupexpr(xvect_t *v)
- {
- EXPR *x, *y;
- int n = v->n, m = v->m;
- if (n <= 0) fatal("internal compiler error");
- if (m < 0) m = 0;
- y = v->xv[--n];
- x = funexpr(VOIDOP);
- while (n > m)
- x = pairexpr(v->xv[--n], x);
- v->xv[n++] = x; m = n;
- v->xv[n++] = y;
- v->n = n; v->m = m;
- return v;
- }
- static EXPR *tupleexpr(xvect_t *v)
- {
- EXPR *x;
- int n;
- if (v->m >= 0) groupexpr(v);
- n = v->n;
- if (n <= 0) fatal("internal compiler error");
- x = v->xv[--n];
- while (n > 0)
- x = pairexpr(v->xv[--n], x);
- free(v->xv);
- free(v);
- return x;
- }
- static EXPR *listexpr(xvect_t *v)
- {
- EXPR *x;
- int n;
- if (v->m >= 0) groupexpr(v);
- n = v->n;
- if (n <= 0) fatal("internal compiler error");
- x = v->xv[--n];
- while (n > 0)
- x = consexpr(v->xv[--n], x);
- free(v->xv);
- free(v);
- return x;
- }
- static EXPR *streamexpr(xvect_t *v)
- {
- EXPR *x;
- int n;
- if (v->m >= 0) groupexpr(v);
- n = v->n;
- if (n <= 0) fatal("internal compiler error");
- x = v->xv[--n];
- while (n > 0)
- x = appexpr(appexpr(funexpr(SCONSOP), v->xv[--n]), x);
- free(v->xv);
- free(v);
- return x;
- }
- static struct option longopts[] = QC_OPTS;
- static struct option all_longopts[] = Q_OPTS;
- static int
- getintarg(char *s, int *i)
- {
- char *t = s;
- while (isspace(*t)) t++;
- s = t;
- while (isdigit(*t)) t++;
- if (t == s) return 0;
- while (isspace(*t)) t++;
- if (*t) return 0;
- *i = atoi(s);
- return 1;
- }
- static void
- parse_opts(argc, argv, pass)
- int argc;
- char **argv;
- int pass; /* 0 denotes source, 1 command line pass */
- {
- int c, longind;
- optind = 0;
- while ((c = getopt_long(argc, argv,
- pass?QC_OPTS1:Q_OPTS1,
- pass?longopts:all_longopts,
- &longind)) != EOF)
- switch (c) {
- case QC_PEDANTIC:
- wflag = 2;
- break;
- case QC_PARANOID:
- wflag = 3;
- break;
- case QC_NO_PRELUDE:
- prelude = NULL;
- break;
- case QC_PRELUDE:
- prelude = optarg?optarg:prelude;
- break;
- case QC_ENCODING: {
- #if defined(HAVE_UNICODE) && defined(HAVE_ICONV)
- if (optarg)
- if (pass) {
- iconv_t ic = iconv_open("UTF-8", optarg);
- if (ic == (iconv_t)-1) {
- char msg[MAXSTRLEN];
- sprintf(msg, "unknown encoding `%s'", optarg);
- fatal(msg);
- } else {
- iconv_close(ic);
- default_codeset = optarg;
- }
- } else /* errors will be caught later by lexer */
- default_codeset = optarg;
- #else
- fprintf(stderr, "%s: warning: --encoding option not supported\n", self);
- #endif
- break;
- }
- case 'd':
- if (pass)
- dflag = 1;
- break;
- case 'h':
- hflag = 1;
- break;
- case 'l':
- list = optarg?optarg:list;
- break;
- case 'n':
- nflag = 1;
- break;
- case 'o':
- code = optarg?optarg:code;
- break;
- case 'p':
- if (optarg) {
- change_qpath(optarg);
- if (!qpath) fatal("memory overflow");
- }
- break;
- case 't': {
- int sz;
- if (optarg && getintarg(optarg, &sz) && sz > 0)
- hashtbsz = sz;
- else {
- char msg[MAXSTRLEN];
- sprintf(msg, "invalid size `%s'", optarg?optarg:"");
- fatal(msg);
- }
- break;
- }
- case 'v':
- vflag = 1;
- break;
- case 'w': {
- int level = 1;
- if (optarg && (!getintarg(optarg, &level) || level < 0 || level > 255)) {
- char msg[MAXSTRLEN];
- sprintf(msg, "invalid warning level `%s'", optarg?optarg:"");
- fatal(msg);
- }
- wflag = level;
- break;
- }
- case 'V':
- Vflag = 1;
- break;
- /* interpreter options (ignored): */
- case Q_GNUCLIENT:
- case Q_DEBUG_OPTIONS:
- case Q_BREAK:
- case Q_PROMPT:
- case Q_DEC:
- case Q_HEX:
- case Q_OCT:
- case Q_STD:
- case Q_SCI:
- case Q_FIX:
- case Q_HISTFILE:
- case Q_HISTSIZE:
- case Q_INITRC:
- case Q_NO_INITRC:
- case Q_EXITRC:
- case Q_NO_EXITRC:
- case Q_NO_EDITING:
- case Q_STACKSIZE:
- case Q_MEMSIZE:
- case 'e':
- case 'i':
- case 'q':
- case 'c':
- case 's':
- break;
- default:
- exit(1);
- }
- }
- static int sargc;
- static char **sargv;
- static void
- get_source_opts(FILE *fp)
- {
- char s[MAXSTRLEN];
- int i;
- sargc = 1;
- sargv = aalloc(1, sizeof(char*));
- *sargv = strdup(self);
- while (!feof(fp) && !ferror(fp) &&
- fgets(s, MAXSTRLEN, fp)) {
- int l = strlen(s);
- if (l > 0 && s[l-1] == '\n') s[l-1] = '\0', l--;
- if (l == 0)
- continue;
- else if (strncmp(s, "#!", 2) == 0)
- if (isspace(s[2])) {
- char *p = s+3;
- while (isspace(*p)) p++;
- sargv = arealloc(sargv, sargc, 1, sizeof(char*));
- sargv[sargc++] = strdup(p);
- } else
- continue;
- else
- break;
- }
- sargv = arealloc(sargv, sargc, 1, sizeof(char*));
- sargv[sargc] = NULL;
- }
- main(argc, argv)
- int argc;
- char **argv;
- {
- int c, longind;
- char *s;
- #if defined(HAVE_UNICODE) && defined(HAVE_LOCALE_H)
- setlocale(LC_ALL, "");
- #endif
- #ifdef _WIN32
- InstallSignalHandler();
- #endif
- /* get program name: */
- self = argv[0];
- /* get environment settings: */
- if ((s = getenv("QPATH")) != NULL)
- init_qpath(s);
- else
- init_qpath(QPATH);
- if (!qpath) fatal("memory overflow");
- if ((s = getenv("QWARN")) != NULL) {
- int level;
- if (getintarg(s, &level) && level >= 0 && level <= 255)
- wflag = level;
- }
- /* scan command line to obtain the first source file name: */
- opterr = 0;
- while ((c = getopt_long(argc, argv, Q_OPTS1,
- longopts, &longind)) != EOF)
- ;
- opterr = 1;
- /* get options from the main script: */
- if (argc-optind >= 1 && strcmp(argv[optind], "-")) {
- char fname[MAXSTRLEN], fname2[MAXSTRLEN];
- FILE *fp;
- if (chkfile(searchlib(fname, argv[optind])) &&
- (fp = fopen(fname, "r")) != NULL ||
- chkfile(searchlib(fname, strcat(strcpy(fname2, argv[optind]),
- ".q"))) &&
- (fp = fopen(fname, "r")) != NULL) {
- get_source_opts(fp);
- fclose(fp);
- parse_opts(sargc, sargv, 0);
- }
- }
- /* get command line options: */
- parse_opts(argc, argv, 1);
- argc -= optind, argv += optind;
- if (Vflag) {
- printf(signon, version, sysinfo, year);
- printf(copying);
- printf(helpmsg, self);
- exit(0);
- }
- if (hflag) {
- printf(usage, self);
- sprintf(opts, QC_OPTMSG, QPATH, HASHTBSZ);
- fputs(opts, stdout);
- exit(0);
- }
- /* install break and term handlers: */
- sigint(break_handler);
- sigterm(break_handler);
- sighup(break_handler);
- /* install gmp memory handlers */
- mp_set_memory_functions(gmp_allocate, gmp_reallocate, gmp_free);
- /* set code file id: */
- sprintf(outid, OUTID, version, sysinfo);
- /* compile: */
- if (*list) {
- FILE *fp;
- if (!(fp = fopen(list, "w"))) {
- fprintf(stderr, "%s: error creating %s\n",
- self, list);
- exit(1);
- } else {
- fclose(fp);
- freopen(list, "w", stderr);
- }
- }
- if (!(codefp = fopen(code, "wb"))) {
- fprintf(stderr, "%s: error creating %s\n",
- self, code);
- exit(1);
- }
- mainno = -1;
- write_header();
- inittables();
- if (!initlex(argc, argv) || yyparse() == 0 && nerrs == 0) {
- /* generate code: */
- write_strsp();
- write_limbsp();
- write_hashtb();
- write_symtb();
- write_TA();
- write_matchtb();
- write_inittb();
- write_modtb();
- fix_header();
- checkint();
- if (nflag) {
- fclose(codefp);
- remove(code);
- } else
- fclose(codefp);
- if (list && !nwarns) {
- fclose(stderr);
- remove(list);
- }
- if (vflag)
- statistics();
- exit(0);
- } else {
- checkint();
- fclose(codefp);
- remove(code);
- if (vflag)
- putchar('\n');
- exit(1);
- }
- }