(* 31V4 Assignment 2 - PDP subset assembler *)
(* Written by J.G.Harston (C)HCE            *)

(* Assem module. Entry at do_op_code to assemble the supplied opcode and *)
(* return the code in the cache with words set to the number of words.   *)

IMPLEMENTATION MODULE Assem;

FROM Parser IMPORT words,cache,error,PC,Symbol_Type,text,txtln,err_txt,
            get_symbol,ln_ptr,txt_buf,GetOct,Assign,buf_len,mesg_txt,
            FindOct,no_label;

FROM Symbols IMPORT Label, find_label;

PROCEDURE do_op_code;
VAR base:INTEGER;
BEGIN             (* Check for all the opcodes. base is set to the
                     octal number following the opcode if a match is made. *)
  error:=FALSE;
  base:=match(text,'MOV,010000,MOVB,110000,CMP,020000,ADD,060000,+');
  IF base<>-1 THEN do_2_oper(base); RETURN; END;
  base:=match(text,'CLR,005000,TST,005700,TSTB,105700,DEC,005300,+');
  IF base<>-1 THEN do_1_oper(base); RETURN; END;
  base:=match(text,'BGT,003000,BNE,001000,+');
  IF base<>-1 THEN do_branch(base); RETURN; END;
  base:=match(text,'JSR,004000,+');
  IF base<>-1 THEN do_jsr(base); RETURN; END;
  base:=match(text,'RTS,000200,+');
  IF base<>-1 THEN do_1_reg(base); RETURN; END;
  error:=TRUE;   (* No match, so flag the non-recognition. *)
  Assign(err_txt,'Unrecognised opcode');
END do_op_code;

PROCEDURE do_2_oper(base:INTEGER);
(* This procedure deals with opcode with two parameters of the form
   COM src,dst. *)
VAR symbol:Symbol_Type;
    src:INTEGER;
BEGIN
  symbol:=get_symbol(text);  (* Get the next symbol *)
  src:=get_src_dst(text);    (* decode it as the source *)
  IF error THEN              (* If an error occured, indicate where it is
                                and return *)
    Assign(mesg_txt,' in source.');
    RETURN;
  END;
  IF NOT check_comma() THEN RETURN; END;
                             (* If no comma, then return with the error *)
  base:=base+src*64;
  do_1_oper(base);           (* Do the second parameter *)
  IF error THEN              (* If an error occured, indicate where *)
    Assign(mesg_txt,' in destination.');
  END;
END do_2_oper;

PROCEDURE do_1_oper(base:INTEGER);
(* This procedure deals with codes with single operands, and with the
   second operand of two operand opcodes. *)
VAR symbol:Symbol_Type;
    dst:INTEGER;
BEGIN
  symbol:=get_symbol(text);
  dst:=get_src_dst(text);     (* Decode the instruction *)
  base:=base+dst;
  cache[0]:=base;             (* Put the code into the cache, and *)
  words:=words+1;             (* increment the word count *)
END do_1_oper1;

PROCEDURE do_branch(base:INTEGER);
(* This procedure deals with branches *)
VAR symbol:Symbol_Type;
    value,temp:INTEGER;
BEGIN
  symbol:=get_symbol(text);
  temp:=0;
  value:=GetValue(text,temp)-PC-2;
  value:=value DIV 2;        (* The value used is the offset from the next
                                instruction, divided by 2 *)
  words:=1;
  IF (value<-128) OR (value>127) THEN
    error:=TRUE;             (* Check the range *)
    Assign(err_txt,'Branch out of range');
   ELSE
    IF value<0 THEN value:=256+value; END; (* get 2's compliment form *)
    cache[0]:=base+value;    (* Store in the cache *)
  END;
END do_branch;

PROCEDURE find_register(text:txtln):INTEGER;
(* This routine decodes the text to give a register number. If the register
   is not recognised, an error is flagged. *)
VAR reg:INTEGER;
BEGIN
  reg:=get_reg(text);        (* Find the register number *)
  IF reg=-1 THEN
    error:=TRUE;             (* If not recognised, flag it *)
    Assign(err_txt,'Register not recognised');
  END;
  RETURN reg;
END find_register;

PROCEDURE check_comma():BOOLEAN; (* Returns FALSE if no comma found *)
BEGIN                           (* If no comma, error message set *)
  IF ln_ptr<buf_len THEN
    IF txt_buf[ln_ptr]=',' THEN
      ln_ptr:=ln_ptr+1;      (* move the pointer past the comma *)
      RETURN TRUE;
    END;
  END;
  error:=TRUE;               (* No comma, so signal error *)
  Assign(err_txt,'Second parameter missing');
  RETURN FALSE;
END check_comma;

PROCEDURE do_jsr(base:INTEGER);
(* This procedure deals with the opcodes of the form COM reg,dst. Currently, the
   only opcode that does this is JSR. *)
VAR reg:INTEGER;
    symbol:Symbol_Type;
BEGIN
  symbol:=get_symbol(text);
  reg:=find_register(text);  (* Look for the register *)
  IF check_comma()=FALSE THEN RETURN; END;
                             (* If no comma, return with the error *)
  do_1_oper(base+reg*64)     (* Do the single operand after the comma *)
END do_jsr;

PROCEDURE do_1_reg(base:INTEGER);
(* This procedure deals with commands of the form COM reg. Currently, this
    is only RTS. *)
VAR reg:INTEGER;
    symbol:Symbol_Type;
BEGIN
  symbol:=get_symbol(text);
  reg:=find_register(text);  (* Look for the register *)
  IF reg=-1 THEN RETURN; END;(* If can't find one, return with the error *)
  cache[0]:=base+reg;        (* Put the opcode into the cache *)
  words:=1;
END do_1_reg;

PROCEDURE get_src_dst(text:txtln):INTEGER;
(* This procedure decodes the text given as a source or destination operand.
    It returns the addressing mode and the register used as the value to be
    put into the source or destination field of the opcode *)
VAR value,temp:INTEGER;
BEGIN
  IF (text[0]='R') OR (text[0]='S') OR (text[0]='P') THEN
                             (* Check if it is Rn, SP or PC *)
    value:=get_reg(text);
    IF value<>-1 THEN RETURN value; END;
                             (* If ok, then return with the register value
                                for mode 0 *)
  END;
(* We've got here. If the line started with R,S or P, then it hasn't been
   recognised as a register. ie it isn't Rn, SP or PC, so it must be a
   label *)
  CASE text[0] OF
                             (* (Rg) and (Rg)+ *)
    '(' : IF text[4]='+' THEN value:=16; (* mode 2 *)
                              text[4]:=' '; (* remove '+' sign *)
                         ELSE value:=8; (* mode 1 *)
                         END;
          value:=value+find_d_reg(0); | (* find register *)
                             (* #number *)
    '#' : temp:=1;
          value:=FindOct(text,temp); (* Get oct number from after '#' *)
          cache[words+1]:=value; (* Put it into the cache *)
          words:=words+1;
          value:=23; | (* mode 2, reg 7 *)
                             (* -(Rg) *)
    '-' : value:=find_d_reg(1);
          value:=value+32; (* mode 4, reg R *)
                             (* @... *)
    '@' : CASE text[1] OF
                             (* @(Rg) and @(Rg)+ *)
            '(' : IF text[5]='+' THEN
                    text[5]:=' '; (* Remove the '+' sign *)
                    value:=find_d_reg(1)+24; (* mode 3 *)
                   ELSE
                    error:=TRUE;
                    Assign(err_txt,'+ or - missing?');
                  END; |
                                     (* @-(Rg) *)
            '-' : value:=find_d_reg(2)+40; | (* mode 5 *)
                                     (* @#value *)
            '#' : temp:=2; value:=GetValue(text,temp);
                  cache[words+1]:=value;
                  words:=words+1;
                  value:=31; (* mode 3, reg 7 *)
           ELSE (* The following is not in the brief: *)
            (* must be a mode 7 : @xxx or @xxx(Rn) *)
            temp:=1; value:=GetValue(text,temp);
            value:=value-PC-words*2-2;
            IF value<0 THEN
              value:=10000H+value; (* Put into 16bit 2s complement form *)
            END;
            cache[words+1]:=value;
            words:=words+1;
            IF text[temp]='(' THEN
              (* @xxx(Rn) *)
              value:=find_d_reg(temp)+56 (* mode 7 *)
             ELSE
              (* @xxx *)
              value:=63; (* mode 7, reg 7 *)
            END;
          END
   ELSE
    (* get value *)
    temp:=0; value:=GetValue(text,temp);
    words:=words+1;
    cache[words]:=value-PC-words*2-2;
    IF cache[words]<0 THEN
      cache[words]:=cache[words]+10000H;
    END; (* Put into 16bit 2's complement form *)
    IF text[temp]='(' THEN   (* value(Rg) *)
      value:=find-d-reg(temp)+48; (* mode 6 *)
     ELSE
      value:=55; (* mode 6, reg 7 *)
    END;
  END;
  RETURN value;
END get_src_dst;

PROCEDURE find_d_reg(ptr:INTEGER):INTEGER;
(* Decodes text to find a defered register.
   ptr is the number of preceding characters to ignore
   0 is for (..)    1 is for -(..) or +(..), etc.  *)
VAR loop,reg:INTEGER;
BEGIN
  IF text[ptr]<>'(' THEN (* Check we have an opening bracket *)
    error:=TRUE;
    Assign(err_txt,'Missing (');
    RETURN -1;
  END;
  IF text[ptr+3]<>')' THEN   (* Also a closing bracket *)
    error:=TRUE;
    Assign(err_txt,'Missing ) in defered register');
    RETURN -1;
  END;
(* We have an '(' and a ')' *)
  FOR loop:=0 TO 8-ptr DO
    text[loop]:=text[loop+ptr+1]
  END;
(* Move back to remove the opening '(' *)
  text[2]:=' ';
(* Prevent the match routine from tripping up *)
  reg:=find_register(text);
  IF reg:=-1 THEN
    error:=TRUE;
    Assign(err_txt,'Defered register unrecognised');
  END;
  RETURN reg;
END find_d_reg;

PROCEDURE get_reg(text:txtln):INTEGER;
(* Looks at the text to see if it is a register *)
VAR reg:INTEGER;
BEGIN
  IF text[0]<>'R' THEN (* See if it's PC or SP *)
    reg:=match(text,'SP,6,PC,7,+');
   ELSE
    reg:=ORD(text[1])-48;
    IF (reg<0) OR (reg>7) THEN reg:=-1; END;
  END;
RETURN reg; (* Returns 0-7 for register, -1 for unrecognised. *)
END get_reg;

PROCEDURE GetValue(text:txtln; VAR pntr:INTEGER):INTEGER;
(* Looks at the text, starting as pntr and gets a value from it. Either as
   an octal constant or a label *)
VAR val,pnt2:INTEGER;
    labl:label;
    found:BOOLEAN;
    ch:CHAR;
BEGIN
  IF (text[pntr]<'0') OR (text[pntr]>'z') OR
     ((text[pntr]>'0') AND (text[pntr]<'A')) THEN
    error:=TRUE;             (* A cursory check to remove strange things *)
    Assign(err_txt,'Badly formed value');
    RETURN 0;
  END;
  IF (text[pntr]>='0') AND (text[pntr]<='7') THEN
    val:=GetOct(text,pntr);
               (* If it starts with an octal digit, decode it as a constant *)
   ELSE
    pnt2:=0; (* Otherwise, look at it as a label *)
    REPEAT
      ch:=text[pntr];
      labl[pnt2]:=ch;
      pnt2:=pnt2+1; pntr:=pntr+1;
    UNTIL (ch=0c) OR (pnt2>6) OR (pntr>10) OR
          ((ch<'a') AND (ch>'Z')); (* <-- This bit removes [ \ ] ^ _ ` *)
    labl[pnt2-1]:=0c;
    found:=find_label(labl,val);
    IF NOT found THEN
      val:=PC+4;        (* If not defined, signal no label, but don't give *)
      no_label:=TRUE;   (* an error.  Also return a dummy value of PC+4 *)
      Assign(err_txt,'Label not defined');
    END;
  END;
  RETURN val;
END GetValue;

PROCEDURE match(input:ARRAY OF CHAR; data:ARRAY OF CHAR):INTEGER;
(* This procedure is used to look through a table to match the text given.
   The data is given in the form xxxx,nnnn,xxxx,nnnn....,+ where
   xxxx is a string of upper case characters to match against, and nnnn
   is the octal of the number to return if the match is made. The data
   string is terminated with an entry of '+'. If no match is made, -1 is
   returned. *)
VAR inptr,dptr,value,loop:INTEGER;
    found:BOOLEAN;
    ch:CHAR;
BEGIN
  found:=FALSE; inptr:=0; dptr:=0;
  REPEAT
    ch:=input[inptr];
    IF ch=data[dptr] THEN    (* If the current chars match, then go on to
                                the next ones *)
      inptr:=inptr+1; dptr:=dptr+1;
      IF (data[dptr]=',') AND (* If we are at the end of the data and the
                                 matching text , signal found *)
         ((input[inptr]=' ') OR (input[inptr]=0c) OR (input[inptr]=')')) THEN
        found:=TRUE;  (*  That's for when testing against registers ^ *)
      END;
     ELSE (* Otherwise, skip past the two commas *)
      FOR loop:=0 TO 1 DO
        REPEAT
          dptr:=dptr+1;
        UNTIL data[dptr-1]=',';
      END;
      inptr:=0;    (* and reset the input pointer to the start *)
    END;
  UNTIL found OR (data[dptr]='+'); (* End if we have finished, of have got
                                      a match *)
  IF NOT found THEN RETURN -1; END;(* If no match, return -1 *)
  dptr:=dptr+1;    (* Otherwise return the octal number *)
  value:=GetOct(data,dptr);
  RETURN value;
END match;

END Assem.