%{
#include <ctype.h>
#include <stdio.h>

extern yylex();
extern yyerror(char *s);
extern int endsrc;
extern int formal_pars;
extern int lineCount;
extern char *idtable[];

extern case_flip(int p);

int block_count = 0;
extern int justz;

extern void storesyl(int p1);

extern void store2syl(int p1);
/* sstore 2-syllable instruction p1 */

extern void qnum(int q);
/* confirms that q is a valid Q-store number */

extern int twosylqx(int instr, int q1, int q2);
/* evaluate two syllable Q-store instruction with 2 Q-store numbers in it
   or one Q-store number and a specified lower byte  */

extern void store3syl(int instr, int addr);
/* takes the output from data loc and embeds in the instruction */

extern void nonums(int i1);
// process instructions with no parameters

extern void onenum(int i1, int n1);

extern int tablocate(unsigned char *s);
/* locate this character string as though it were an identifier */
/* fancy characters in instruction mnemonics need unsigned char */

extern int idtablocate(char *s, int id);
/* locate the character string formed by concatenating s and id as though it were an identifier */

extern int idtablocate2(char *s, int id1, int id2, int id3);
/* joins together all four components like previous routine, id3 can be -ve to indicate null string */

extern int jumptest(int idj, int idz, char *syn);
// handles synonyms such as J>=Z -- JGEZ
// idj must be "J" and idz "Z" for the instruction to be valid
// syn is the all-letters mnemonic that will be used for table lookup

extern int codeloc(int lab);
// get absolute address of Usercode label

extern void startnewword(int n);
// round address to multiple of n words

void twonums(int i1, int n1, int n2);
void justaddr(int i1, int a1);
void numaddr(int i1, int n1, int a1);

extern void mpmi(int i1, int pm, int i2, int n);
/* Only valid for instructions of the form M+Iq, M-Iq */

extern void setinc(int i1, int n1, int n2);
// process Iq=+1, etc

extern void qval(int n1,int n2,int n3);
// process Q-store format word

%}

/*               Atlas Autocode ABC Phrase Structure */
/*      All Atlas Autocode statements belong to the class P<SS> as defined */

/*    The built in phrases are  */
                              /* -> P<null>   */
%token P_NAME                   /*  P<name> */
%token P_SEPARATOR              /*  P<separator> */
%token P_CONST                  /*  P<const> */
                                /* Those above are not used */
%token P_COMMENT_TEXT           /*  P<comment text> */
%token P_CAPTION_TEXT           /*  P<caption text> */
%token P_UNSIGNED_INTEGER       /*  P<unsigned integer> */

/*    Tokens corresponding to % words in AA */
%token ADDR
%token AND
%token ARRAY
%token BEGIN
%token BOUND
%token CAPTION
%token CHECKS
%token CODE
%token COMMENT
%token COMPILE
%token CYCLE
%token END
%token FAULT
%token FN
%token IF
%token IGNORE
%token INTEGER
%token LIST
%token M
%token MAP
%token MONITOR
%token NAME
%token OF
%token OR
%token PERM
%token PROGRAM
%token QUERIES
%token REAL
%token REPEAT
%token RESULT
%token RETURN
%token ROUTINE
%token SPEC
%token STOP
%token SWITCH
%token THEN
%token UNLESS

/*    Tokens concocted by DH */
%token IDENTIFIER
%token NEWLINE
%%

program : statements   END OF PROGRAM    { endsrc = 1;  printf("// Reached end of program\n"); }
        ;

statements  :  single_statement
        | statements single_statement
        ;

flip_case1 :       { case_flip(1); }
           ;

flip_case0 :       { case_flip(0); }
           ;

/* This has to be before single_statement for correct resolution of the reduce/reduce conflict on '*' */
machine_code_sequence : flip_case1 '*' machine_instrn flip_case0 separator
                      | machine_code_sequence flip_case1 '*' machine_instrn flip_case0 separator
                      ;

single_statement  :   unconditional_instrn separator
        |        if_or_unless condition THEN unconditional_instrn separator
        |        unconditional_instrn if_or_unless condition separator
        |        CYCLE IDENTIFIER actual_parameters_p '=' plus_p  exprn ',' plus_p exprn ',' plus_p exprn separator
        |        REPEAT separator
        |        type name_list separator
        |        type_p ARRAY array_list separator
        |        SWITCH switch_list separator
        |        rt SPEC IDENTIFIER formal_parameter_defn_p separator
        |        SPEC IDENTIFIER formal_parameter_defn_p separator
        |        rt IDENTIFIER formal_parameter_defn_p separator       {  printf("%5d Level = %d Enter %s\n", lineCount, ++block_count, idtable[$2]); }
        |        BEGIN separator                                       {  printf("%5d Level = %d BEGIN\n", lineCount, ++block_count); }
        |        END separator                                         {  printf("%5d Level = %d END\n", lineCount, --block_count); }
        |        P_UNSIGNED_INTEGER ':'
    /*  |        IDENTIFIER '(' plus_p constant ')' ':'         with luck we will not need this -- but we do */
        |        IDENTIFIER actual_parameters ':'      /* so liberalise the grammar, and sort it out semantically */
        |        COMPILE QUERIES separator
        |        IGNORE QUERIES separator
        |        COMMENT                    /* original was COMMENT P_COMMENT_TEXT separator */
        |        '!' P_COMMENT_TEXT separator
        |        LIST separator
        |        END OF LIST separator
        |        M CODE separator
        |        END OF M CODE separator
        |        machine_code_sequence
        |        COMPILE ARRAY BOUND CHECKS separator
        |        IGNORE ARRAY BOUND CHECKS separator
        |        END OF PERM separator
        |        FAULT fault_list separator
        |        separator
        |        P_UNSIGNED_INTEGER IDENTIFIER ':'             /* DH extra to accommodate labels(?) like 58P: */
        ;

unconditional_instrn :  IDENTIFIER actual_parameters '=' plus_p exprn query_p
        |       IDENTIFIER actual_parameters
        |       '-' '>' P_UNSIGNED_INTEGER
        |       '-' '>' IDENTIFIER '(' plus_p exprn ')'
    /*  |       CAPTION P_CAPTION_TEXT   -- replaced by rule below */
        |       CAPTION                  /* value of token is pointer to string */
        |       RETURN 
        |       RESULT '=' plus_p exprn
        |       STOP 
        |       MONITOR STOP 
        |       MONITOR P_UNSIGNED_INTEGER
        ;

plus_p  :  '+'
        | '-'
        |
        ;

exprn : operand rest_of_exprn
      | '|' operand '|'         /* introduced by DH -- there is one occurrence of !N! which DH changed to |N| */
      ;


rest_of_exprn : operator operand rest_of_exprn
              |
              ;


operand  :  IDENTIFIER actual_parameters_p
        |constant
        |'(' plus_p exprn ')'
    /*  |plus_p exprn      this has to be bad news - causes lots of conflicts */
    /*  |                  It is not clear under what cireumstances operand can be null */
        ;


operator  :  '*' '*'
        | '+'
        | '-'
        | '*'
        | '/'           /* seems not to be in the original syntax */
    /*  | (* *)         what is this? */
        |
        ;

actual_parameters_p  :  '(' plus_p exprn rest_of_actual_parameters ')'
        |
        ;

rest_of_actual_parameters :   ',' plus_p exprn rest_of_actual_parameters
        |
        ;

query_p :  '?'
        |
        ;

comma_p : ','
        |
        ;

if_or_unless : IF 
             | UNLESS
             ;

type  : INTEGER 
      | REAL
      ;

type_p  : INTEGER 
        | REAL 
        |
        ;

name_list : IDENTIFIER rest_of_name_list
          ;

rest_of_name_list  :   ',' name_list
        |
        ;

array_list  :  name_list '(' bound_pair_list ')' rest_of_array_list
        ;

rest_of_array_list  :  ',' array_list
        |
        ;

bound_pair_list  :      plus_p exprn ':' plus_p exprn rest_of_bp_list
        ;

rest_of_bp_list  :  ',' bound_pair_list
        |
        ;

switch_list  :  name_list '(' plus_p constant ':' plus_p constant ')' rest_of_switch_list
        ;

rest_of_switch_list  :  ',' switch_list
        |
        ;

rt  :   ROUTINE 
        | REAL FN 
        | INTEGER FN
        | REAL MAP 
        | INTEGER MAP
        ;

fp_start : '('             { formal_pars = 1; }           /* flags yylex() to recognise ",%" as ';' */

formal_parameter_defn_p  :  fp_start fp_list ')'       { formal_pars = 0; }
        |
        ;

fp_list  :  fp_delimiter name_list rest_of_fp_list
        ;

rest_of_fp_list  : ';'  fp_list             /* semicolon introduced by DH to remove ambiguity, introduced by yylex() */
        |
        ;

fp_delimiter  :  comma_p rt
        | comma_p type NAME
        | comma_p type
        | comma_p type_p ARRAY NAME 
        | ADDR
        ;

condition : simple_cond AND and_cond
          | simple_cond OR or_cond
          | simple_cond
          ;


and_cond : simple_cond rest_of_and_cond
         ;

rest_of_and_cond : AND and_cond
                 |
                 ;

or_cond : simple_cond rest_of_or_cond
        ;

rest_of_or_cond : OR or_cond
        |
        ;

simple_cond : plus_p exprn comparator plus_p exprn rest_of_simple_cond
            | '(' or_cond ')'                                   /* added by DH, seems to be part of the language */
            ;

rest_of_simple_cond  :  comparator plus_p exprn                   /* plus_p was originally <+'> */
        |
        ;

comparator : '='
           | '#'
           | '<' '='
           | '<'
           | '>' '='
           | '>'
           ;

fault_list  :  P_UNSIGNED_INTEGER rest_of_N_list '-' '>' P_UNSIGNED_INTEGER rest_of_fault_list
        ;

rest_of_N_list  :           ',' P_UNSIGNED_INTEGER
        |
        ;

rest_of_fault_list  :  ',' fault_list
        |
        ;

/*      (P machine_instrn             See KDF9 programming manual)  */


/* productions generated by DH */

separator : ';'
          | NEWLINE
          ;

machine_instrn : IDENTIFIER ':'                        /* no idea what this means -- some sort of label */  { printf("Funny * %s :\n", idtable[$1]); }

               | IDENTIFIER P_UNSIGNED_INTEGER ':'                /* e.g. SET 33P: */        { onenum($1, $2); }  /* TEMP !!! */
               | IDENTIFIER IDENTIFIER P_UNSIGNED_INTEGER         /* e.g. SET B33 */         { onenum(idtablocate(idtable[$1], $2), $3); }

               | flip_case0 '*' '`' IDENTIFIER actual_parameters  /* no idea what this means */
               | flip_case0 '*' '@' IDENTIFIER actual_parameters  /* no idea what this means */
               | flip_case0 '*' operand                           /* fetch variable, etc */
               | flip_case0 '*' '=' IDENTIFIER actual_parameters  /* store in variable -- possibly array element */

               | IDENTIFIER                                       /* e.g. DUP  REV  PERM */  { nonums($1); }
               | '=' IDENTIFIER                                   /* only =TR  =LINK */      { nonums(idtablocate("=", $2)); }
               | IDENTIFIER P_UNSIGNED_INTEGER                    /* e.g. SET 3  Q12  E456 */{ onenum($1, $2); }
               | '=' IDENTIFIER P_UNSIGNED_INTEGER                /* e.g. =Q12  =E456 */     { onenum(idtablocate("=", $2), $3); }
               | '=' '+' IDENTIFIER P_UNSIGNED_INTEGER            /* e.g. =+Q13 */           { onenum(idtablocate("=+", $3), $4); }

               | IDENTIFIER P_UNSIGNED_INTEGER IDENTIFIER P_UNSIGNED_INTEGER                 { twonums(idtablocate(idtable[$1], $3), $2, $4); }
                                                                  /* e.g. M8M9  CI7TOQ11 */
               | '=' IDENTIFIER P_UNSIGNED_INTEGER IDENTIFIER P_UNSIGNED_INTEGER             { twonums(idtablocate2("=", $2, $4, -1), $3, $5); }
                                                                  /* e.g. =M8M9 */

               | IDENTIFIER P_UNSIGNED_INTEGER IDENTIFIER P_UNSIGNED_INTEGER IDENTIFIER      { twonums(idtablocate2(idtable[$1], $3, $5, -1), $2, $4); }
                                                                  /* e.g. M8M9QHN  J23C14NZ */
               | '=' IDENTIFIER P_UNSIGNED_INTEGER IDENTIFIER P_UNSIGNED_INTEGER IDENTIFIER  { twonums(idtablocate2("=", $2, $4, $6), $3, $5); }
                                                                  /* e.g. =M8M9Q */

               | IDENTIFIER P_UNSIGNED_INTEGER IDENTIFIER IDENTIFIER P_UNSIGNED_INTEGER      { twonums(idtablocate2(idtable[$1], $3, $4, -1), $2, $5); }
                                                                  /* e.g. CI7 TO Q11 */

               | IDENTIFIER '-' P_UNSIGNED_INTEGER                /* e.g. SHL-8 */           { onenum($1, -$3); }
               | IDENTIFIER '+' P_UNSIGNED_INTEGER                /* e.g. SHL+8 SET+7 */     { onenum($1, $3); }

               | IDENTIFIER P_UNSIGNED_INTEGER '=' IDENTIFIER     /* e.g. J44=Z */     { justaddr(jumptest($1, $4, "JEQZ"), codeloc($2)); }
               | IDENTIFIER P_UNSIGNED_INTEGER '>' IDENTIFIER     /* e.g. J44>Z */     { justaddr(jumptest($1, $4, "JGTZ"), codeloc($2)); }
               | IDENTIFIER P_UNSIGNED_INTEGER '>' '=' IDENTIFIER /* e.g. J44>=Z */    { justaddr(jumptest($1, $5, "JGEZ"), codeloc($2)); }
               | IDENTIFIER P_UNSIGNED_INTEGER '<' '=' IDENTIFIER /* e.g. J44<=Z */    { justaddr(jumptest($1, $5, "JLEZ"), codeloc($2)); }
               | IDENTIFIER P_UNSIGNED_INTEGER '<' IDENTIFIER     /* e.g. J44<Z */     { justaddr(jumptest($1, $4, "JLTZ"), codeloc($2)); }
               | IDENTIFIER P_UNSIGNED_INTEGER '#' IDENTIFIER     /* e.g. J44#Z */     { justaddr(jumptest($1, $4, "JNEZ"), codeloc($2)); }
               | IDENTIFIER P_UNSIGNED_INTEGER '#'                /* e.g. J44# */      { justaddr(jumptest($1, justz, "JNE"), codeloc($2)); }
               | IDENTIFIER P_UNSIGNED_INTEGER '='                /* e.g. J44= */      { justaddr(jumptest($1, justz, "JEQ"), codeloc($2)); }
               | IDENTIFIER P_UNSIGNED_INTEGER IDENTIFIER         /* e.g. J44TR */     { onenum(idtablocate(idtable[$1], $3), $2); }

               | '-'                                                                   { nonums(tablocate("-")); }
               | '-' IDENTIFIER                                   /* e.g. -F -D */     { nonums(idtablocate("-", $2)); }
               | '+'                                                                   { nonums(tablocate("+")); }
               | '+' IDENTIFIER                                   /* e.g. +F +D */     { nonums(idtablocate("+", $2)); }
               | '/'                                              /* divide */         { nonums(tablocate("DIV")); }
               | '/' IDENTIFIER                                   /* e.g. /I /F */     { nonums(idtablocate("DIV", $2)); }
               | IDENTIFIER '-' IDENTIFIER P_UNSIGNED_INTEGER     /* e.g. M-I8 */      { mpmi($1, '-', $3, $4); }
               | IDENTIFIER '+' IDENTIFIER P_UNSIGNED_INTEGER     /* e.g. M+I8 */      { mpmi($1, '+', $3, $4); }

               | IDENTIFIER P_UNSIGNED_INTEGER '=' '-' P_UNSIGNED_INTEGER      /* e.g. I6=-1 */   { setinc($1, $2, -$5); }
               | IDENTIFIER P_UNSIGNED_INTEGER '=' '+' P_UNSIGNED_INTEGER      /* e.g. I6=+1 */   { setinc($1, $2, $5); }
               | IDENTIFIER P_UNSIGNED_INTEGER '=' P_UNSIGNED_INTEGER          /* e.g. I6=1 */    { setinc($1, $2, $4); }

               | P_UNSIGNED_INTEGER '/' P_UNSIGNED_INTEGER '/' P_UNSIGNED_INTEGER      { qval($1, $3, $5); }
                                                                   /* Q-store format constant */

               |                    /* round up to whole word */  { startnewword(1); }
               ;

actual_parameters : actual_parameters_p
                  ;

constant : P_UNSIGNED_INTEGER
         ;

%%