{ > PasCgen }

{ Tutu 17 feb 86 - 1.07 - Range check errors - new non-fatals start at 170 }
{ Tutu 29 jan 86 - Constant pointer size now 4 bytes }
{ Tutu 17 dec 85 - Altered typsz to return ptrsize for most tos quantities
                   also removed maxproc restriction }
{ Tutu 04 sep 85 - Mods to GENUW/SI/STR assume code file open before !}

PROCEDURE ERROR (N : SI);
{
  Turns code generation off.
  If an error has not already occurred at the current character position, then
  insert the error number into the error array and add the current character
  position to the set which contains the position of the error on the line.
  Since all errors over error 164 are fatal, if N is > 164 then goto the end
  of the program.
}
BEGIN
   GENCODE := FALSE;
   IF X.ERRNO < MAXERRS THEN
      IF NOT (X.CHRNO IN ERRSET) THEN
      BEGIN
         ERRSET := ERRSET + [X.CHRNO MOD 255];
         X.ERRNO := SUCC (X.ERRNO);
         X.ERRORS := SUCC (X.ERRORS);
         ERRARAY[X.ERRNO] := N
      END;

   if (n > 164) and (n < 170) then goto 999 { Tutu 1.07 }
{ Tutu - was IF N > 164 THEN GOTO 999 { Fatal }
END; { error }


PROCEDURE ISOERR;
{
  This procedure is called when an Acorn extension has been detected and checks
  that the extensions compiler option is on $X+ .
}
BEGIN
   IF NOT EXT THEN ERROR (14)
END; { isoerr }


PROCEDURE GENUB (VALUE : UB);
{
  This procedure outputs a byte value to the temporary code file (pfile), 
  creating the file first if neccessary and then increments the code pointer.
}
BEGIN
   IF GENCODE THEN
   BEGIN
      IF NOTOPEN THEN
      BEGIN
         REWRITE (PFILE);
         NOTOPEN := FALSE
      END;
      WRITE (PFILE, VALUE)
   END;
   X.CADR := SUCC (X.CADR)
END; { genub }


PROCEDURE GENSTR (PTR, LENGTH : UW);
{
  This proc outputs a string residing anywhere in memory (of length LENGTH) to
  the temp code file one byte at a time using procedure GENUB. Nope - Tutu
  The start of the string in RAM is pointed to by PTR. Code file must be open
}
VAR INDEX : UW;
    NAMES: PACKED RECORD
             CASE BOOLEAN OF
               TRUE  : (TADR : UW);   { Set TADR to address of byte in memory }
               FALSE : (TPTR : ^CHAR) { then output value using pointer }
           END;
BEGIN
   if gencode then
   FOR INDEX := PTR TO PRED (PTR+LENGTH) DO
   BEGIN
      NAMES.TADR := INDEX;
      write (pfile, ord (NAMES.TPTR^)); { Tutu - was GENUB (ORD (NAMES.TPTR^)) }
      X.CADR := succ (X.CADR)
   END
END; { genstr }


PROCEDURE PFLIST;
{
  This procedure adds a record containing the entry point of the current
  procedure to the end of a linked list and increments the current procedure
  number by 1. If there are more than 127 procedures (MAXPROC) then an error is
  generated.
  The list is used at the end of the program to append a table of procedure
  entry points to the end of the program because procedures are called
  indirectly through the table to compact the code. A procedure is called using
  its index into the table and since the 6502 only has 8 bit registers, the
  table can only be 254 bytes long. Proc. number size on ARM is integer now.
}
BEGIN
   NEW (PFNAMES^.NEXT);
   PFNAMES := PFNAMES^.NEXT;
   PFNAMES^.ADR := X.CADR;
   PFNAMES^.NEXT := NIL;
   X.PROCNO := SUCC (X.PROCNO);
{  IF X.PROCNO > MAXPROC THEN ERROR (30) { Tutu - ARM code unrestricted }
END; { pflist }


PROCEDURE DBUGNAME (DESC : SYMREC);
{
  This procedure outputs the procedure name (accessed through the procedure's
  identifier descriptor (DESC)) to the temp code file using procedure GENSTR, 
  having first determined the length of the name.
  The name is always output, or else the translator would get confused. Tutu
}
VAR LENGTH : UW;
    NAMES  : PACKED RECORD
               CASE BOOLEAN OF
                 TRUE  : (TADR : UW);   { Set TADR to address of byte in }
                 FALSE : (TPTR : ^CHAR) { memory then output value using pntr }
             END;
BEGIN
{ Get length of procedure's name }
   LENGTH := 0;
   REPEAT
      LENGTH := SUCC (LENGTH);
      NAMES.TADR := SUCC (DESC.NAMLINK + LENGTH)
   UNTIL NAMES.TPTR^ = ' ';

   IF LENGTH > 250 THEN LENGTH := 250;
   GENUB (77); {Here_is proc_name}
   GENUB (LENGTH);
   GENSTR (SUCC (DESC.NAMLINK), LENGTH)
END; { dbugname }


PROCEDURE OPEN;
{
  This procedure opens the compiler source file (name held in SOURCEFILE).
}
BEGIN
   X.SRCLINE := 0;
   RESET (SOURCE, SOURCEFILE);
  { If Command Line Options not being parsed }
   IF NOT CLO THEN CH := ' ';
   NXTCH := ' ';
   NEWLINE := TRUE
END; { open }


PROCEDURE CLRSTR (VAR NAME : FNAMETYP);
{
  This procedure sets the string passed into the procedure in NAME to null.
}
VAR INDEX : UB;

BEGIN
   FOR INDEX := MAXFNAME DOWNTO 1 DO NAME[INDEX] := CHR (TERMCH)
END; { clrstr }


PROCEDURE GETNAME (VAR FNAME : FNAMETYP);
{
  This procedure reads a filename from the command line (into the string FNAME)
  if one is present. The string is ended by a space, end_of_line or '{'.
}
LABEL 13;

BEGIN
   CLRSTR (FNAME);

   X.INDEX := 1;
   WHILE (SOURCE^ <> ' ') AND (SOURCE^ <> '{') DO
   BEGIN
      IF X.INDEX >= MAXFNAME THEN
      BEGIN
         ERROR (93);
         GOTO 13
      END;
      FNAME[X.INDEX] := SOURCE^;
      X.INDEX := SUCC (X.INDEX);
      GET (SOURCE)
   END;
 13:;
END; { getname }


FUNCTION BYTES (LOW, HIGH : SI): UB;
{
  This function returns the size of a variable that would be needed to hold
  values in the range LOW..HIGH.
  0..255   = 1 byte
  0..65535 = 2 bytes
  others   = 4 bytes
}
BEGIN
   BYTES := 1;
   IF (LOW < 0) OR (HIGH > MAXUW) THEN BYTES := 4
   ELSE
     IF HIGH > 255 THEN BYTES := 2
END; { bytes }


PROCEDURE GENUW (VALUE : UW);
{
  This procedure outputs a 2 byte value to the temp code file by calling GENUB
  twice. Not any more it doesn't ! - Tutu. Relies on code file being open
}
VAR V : PACKED RECORD
          CASE BOOLEAN OF
            TRUE  : ( X  : UW);
            FALSE : ( B1 : UB;  { B1 and B2 overlay X }
                      B2 : UB)
        END;

begin
   if gencode then
   begin
      V.X := VALUE;
      write (pfile, V.B1, V.B2)
   end;
   x.cadr := succ (succ (x.cadr))

{ Tutu - was GENUB (V.B1); GENUB (V.B2) }
end; { genuw }


PROCEDURE GENSI (VALUE : SI);
{
  This procedure outputs a 4 byte value to the temp code file by calling GENUW
  twice. Well, it USED to do ! - Tutu. Relies on code file being open
}
VAR V : PACKED RECORD
          CASE BOOLEAN OF
            TRUE  : ( X  : SI);
            FALSE : ( B1 : UB;  { B1 .. B4 overlay X - Used to be W1, W2 : UW}
                      B2 : UB;
                      B3 : UB;
                      B4 : UB)
        END;

begin
   if gencode then
   begin
      V.X := VALUE;
      write (pfile, V.B1, V.B2, V.B3, V.B4)
   end;
   x.cadr := x.cadr + 4

{ Tutu - was GENUW (V.W1); GENUW (V.W2) }
end; { gensi }


PROCEDURE FLUSH; FORWARD;


PROCEDURE FLUSHNGEN (OP : UB);
{
  This procedure calls procedure FLUSH to flush any BL-code which may be in the
  code buffer and then outputs the BL-code held in OP to the temp code file.
}
BEGIN
   FLUSH;
   GENUB (OP)
END; { flushngen }


PROCEDURE GENOPWTB (OP : UB; TWOBYTES : UW);
{
  This procedure (GENerateOPWithTwoBytes) calls FLUSHNGEN (see above) and then
  outputs a 2 byte value to the temp code file, setting X.LASTADR to the code
  address of the first of the 2 bytes.
}
BEGIN
   FLUSHNGEN (OP);
   X.LASTADR := X.CADR;
   GENUW (TWOBYTES)
END; { genopwtb }


PROCEDURE GENJMP (JUMPOP : UB; ADRES : UW);
{
  This procedure is used to output a BL-code jump instruction to the temp code
  file and resets the active declaration level to the current level (see
  description of X.ACTIVLEV in global var section).
}
BEGIN
   GENOPWTB (JUMPOP, ADRES);
   X.ACTIVLEV := X.LEVEL
END; { genjmp }


PROCEDURE GENLORS (OP : UB; OPERAND : UW);
{
  Variables are accessed at run time by an offset in their activation record.
  If this is less than 255 then a short form of instruction is used otherwise
  the long form is used. This procedure (GENerateLongORShort) is passed the
  short form of the BL-code in OP and adds 42 (to create the long form) to it
  if the OPERAND is > 255. The instruction and the operand are then output to
  the temp code file.
}
BEGIN
   genopwtb (op+42, operand) { Tutu - always generate long form for ARM/Comm }

{ Tutu - was
   IF OPERAND > 255 THEN GENOPWTB (OP+42, OPERAND)
   ELSE
   BEGIN
      FLUSHNGEN (OP);
      GENUB (OPERAND)
   END
}
END; { genlors }


PROCEDURE SETLEV (LEV : UB);
{
  This procedure generates code to set the active display level to LEV.
  47 = global, 48 = current (declaration level), 46, X = level (X)
}
BEGIN
   IF LEV = 1 THEN GENUB (47)
   ELSE
      IF LEV = X.LEVEL THEN GENUB (48)
      ELSE
      BEGIN
         GENUB (46);
         GENUB (PRED (LEV))
      END;
   X.ACTIVLEV := LEV
END; { setlev }


PROCEDURE FLUSH;
{
  This procedure flushes the BL-code buffer if it is not empty, generating code
  to set the active level to that of the variable held in the buffer before
  generating the variable access BL-code.
  The buffer is a single instruction buffer used to modify variable access
  BL-codes. 
}
BEGIN
   IF CBUFF.BASICOP <> 0 THEN
   BEGIN
      CBUFF.BASICOP := 0;
      IF CBUFF.LEV <> X.ACTIVLEV THEN SETLEV (CBUFF.LEV);
      GENLORS (CBUFF.OPCODE, CBUFF.VARADR)
   END
END; { flush }


FUNCTION ISINT (DESC : SYMREC) : BOOLEAN;
{
  This function returns true if the type described by DESC is an integer. 
}
BEGIN
   ISINT := (DESC.IDTYP = SUBR) AND (DESC.REF^.TYP = INT)
END; { isint }


PROCEDURE TYPSZ (DESC : SYMREC; VAR OP, SIZE : UB; PACKCONSTS : BOOLEAN);
{
  This procedure returns :
  in SIZE the No. bytes that this variable / constant uses ie 1234 = 2 bytes, 
  in OP the offset to add to a basic BL-code instruction to get the actual
    instruction eg. 
    VAR a : integer;
        r : packed record
               f : 0..1000
            end;
    a := r.f;

  To push the f onto the stack OP would be 6 and SIZE 2.
  To pop value into a, OP would be 2 and SIZE 4.

  offsets are 0 : bce (ByteCharEnum)
              1 : ptr (pointer
              2 : int (integer)
              3 : rea (real)
              4 : set (set)
              5 : uby (UnsignedByte)
              6 : uwd (UnsignedWord)
              7 : blk (Block)
}
VAR OPCOPY, SIZECOPY : UB;

BEGIN
   OPCOPY := CODE0 (TABSEARCH, ORD (DESC.IDTYP), MLO, MHI{MOVTYPVAL}) MOD 128;
{
  OPCOPY now contains an offset to add to a basic BL-code PULL/PUSH
  instruction depending on the type of variable
}
   IF (DESC.IDTYP = PNTR) AND (DESC.OBJ = KONST)
   THEN SIZECOPY := ptrsize; { Tutu - was 2 }

   IF OPCOPY = 3 THEN SIZECOPY := reasize; { Tutu - real vbl - was 5 }

   IF OPCOPY = 0 { ie variable is a subrange } THEN
   BEGIN
      SIZECOPY := DESC.REF^.SUBRSIZ;
      IF DESC.OBJ = KONST THEN
      BEGIN
         IF PACKCONSTS THEN SIZECOPY := BYTES (DESC.VAL, DESC.VAL)
      END
      ELSE IF DESC.PAK THEN SIZECOPY := BYTES (DESC.REF^.LOW, DESC.REF^.HIGH);

      CASE SIZECOPY OF
      4 : OPCOPY := 2;
      1 : IF DESC.REF^.TYP = INT THEN OPCOPY := 5;
      2 : OPCOPY := 6
      END
      OTHERWISE
   END;

   OP := OPCOPY;
   SIZE := SIZECOPY
END; { typsz }


PROCEDURE GENMOV (OPBASE : UB; DESC : SYMREC);
{
  This procedure is used to construct all push, pop, locate and identify variable
  BL-codes. The instruction may be left in the code buffer (in which case it
  is an instruction that could be added to, ie. part of a record), or sent to
  the temp code file.
}
VAR OPTYP, OP, SIZE : UB;

BEGIN
   TYPSZ (DESC, OPTYP, SIZE, TRUE);
   OP := OPBASE + OPTYP;

   IF DESC.OBJ = KONST {constants} THEN
   BEGIN
      FLUSHNGEN (OPTYP);
      IF SIZE >= 4 THEN
      BEGIN
         GENSI (DESC.VAL);
         if size = reasize then
           if reasize=5 then genub (desc.rv) else gensi (desc.rv)
{ Tutu - was IF SIZE = 5 THEN GENUB (DESC.RV)}
      END
      ELSE IF SIZE = 2
           THEN GENUW (DESC.VAL)
           ELSE GENUB (DESC.VAL)
   END

   ELSE
      IF OPBASE <= POP THEN {locates, pushes & pops}
         IF DESC.NRM THEN { value parameter }
         BEGIN
            FLUSH;
            CBUFF.BASICOP := OPBASE;
            CBUFF.LEV := DESC.LEV;
            CBUFF.VARADR := DESC.ADR;
            CBUFF.OPCODE := OP;
            IF OPBASE = LOCATE THEN CBUFF.OPCODE := LOCATE
            ELSE FLUSH
         END
         ELSE { var parameter }
         BEGIN
            DESC.IDTYP := PNTR;
            DESC.NRM := TRUE;
            GENMOV (PUSH, DESC);
            IF  OPBASE  =  PUSH  THEN GENUB (IPUSH+OPTYP)
            ELSE IF OPBASE = POP THEN GENUB (IPOP+OPTYP)
         END

      ELSE
         IF OPTYP = 7 THEN { block copy or block to stack }
         BEGIN
            IF DESC.IDTYP = CARAY THEN
            BEGIN
               IF X.ACTIVLEV <> ADESCREF^.ALEV MOD 128
               THEN SETLEV (ADESCREF^.ALEV MOD 128);
               GENLORS (10, ADESCREF^.ADESCOFF);       { Psh_Ptr }
               IF ADESC <> 0 THEN GENLORS (41, ADESC); { Use_Offset }
               GENUB (218) { Conformant array block copy }
            END
            ELSE GENLORS (OP, DESC.REF^.VARSIZ)
         END
         ELSE
            IF CBUFF.BASICOP = LOCATE THEN
            BEGIN
               IF OPBASE = IPOP THEN CBUFF.OPCODE := POP + OPTYP
               ELSE
                  IF OPBASE = IDENTIFY
                  THEN CBUFF.OPCODE := 8 { Identify_S }
                  ELSE CBUFF.OPCODE := PUSH + OPTYP;
               FLUSH
            END
            ELSE FLUSHNGEN (OP)
END; { genmov }


PROCEDURE GENRECOFF (VALUE : UW);
{
  This procedure is used in code generation and adds the offset of a field
  inside a record to the base already present if there is one in the code
  buffer. If the code buffer is empty then the offset is put into the buffer
  in case another offset comes along later.
}
BEGIN
   IF VALUE <> 0 THEN
      IF (CBUFF.BASICOP = LOCATE) OR (CBUFF.BASICOP = USEOP)
      THEN CBUFF.VARADR := VALUE + CBUFF.VARADR
      ELSE
      BEGIN
         FLUSH;
         CBUFF.VARADR  := VALUE;
         CBUFF.BASICOP := USEOP;
         CBUFF.OPCODE  := USEOP
      END
END; { genrecoff }


PROCEDURE STORPATCH (ADR : UW; VAL : UW);
{
  This procedure adds a record containing the address in the code produced
  which needs patching and the value to patch it with, to a linked list of
  patches. A machine code routine is used to find the correct position in the
  list to insert the record (because it is faster than Pascal).
}
VAR PATCHDATA, AFTER, BEFORE : PATCHP;
    PATCH : PATCHREC;
    TEMP : SI;

BEGIN
   NEW (PATCHDATA);
  {The list of patches are a linked list of patches ordered in increasing
   address value so to insert a patch in the list the correct position in
   the list must first be found }
   AFTER := PATCH1;
   TEMP := CODE1 (SEARCH, 0, ADR);

   IF AFTER = NIL THEN PATCHDATA^.NEXT := NIL
   ELSE
      IF AFTER^.ADDR = ADR THEN
      BEGIN {A patch to this address already exists so don't do it again}
         DISPOSE (PATCHDATA);
         PATCHDATA := AFTER
      END
      ELSE PATCHDATA^.NEXT := AFTER;

   BEFORE^.NEXT := PATCHDATA;

  { Store patch data in linked list record }
   PATCHDATA^.ADDR  := ADR;
   PATCHDATA^.VALUE := VAL
END; { storpatch }


{$S'PasScan'}