head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.35.50;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.12.11.51;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.25.55;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.03.17;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.13.13;  author jwh;  state Exp;
branches ;
next     53.2;

53.2
date     91.03.15.15.31.20;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.14.07;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.08.59.17;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.15.58.13;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.11.05;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.00.20;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.05.45;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.10.40.15;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.29.52;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.15.36.52;  author jwh;  state Exp;
branches ;
next     44.2;

44.2
date     90.04.04.13.31.37;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.21.54.34;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.13.44.28;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.29.54;  author jwh;  state Exp;
branches ;
next     41.2;

41.2
date     89.12.26.11.36.45;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.12.22;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.35.30;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.20.54;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.10.58;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.23.53;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.02.56;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.12.39;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.15.48.42;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.25.02;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.29.51;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.17.50.47;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.29.07;  author dew;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.13.28;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.10.43.59;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.06.28;  author bayes;  state Exp;
branches ;
next     26.3;

26.3
date     88.09.28.12.19.57;  author bayes;  state Exp;
branches ;
next     26.2;

26.2
date     88.09.28.12.19.43;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.12.19.27;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.08.59.09;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.09.36.18;  author bayes;  state Exp;
branches ;
next     22.3;

22.3
date     87.08.25.18.29.41;  author jws;  state Exp;
branches ;
next     22.2;

22.2
date     87.08.20.15.50.46;  author larry;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.10.13.04;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.13.03.00;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.10.12.53;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.07.33.54;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.14.25.47;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.09.42.02;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.14.59.10;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.08.22.17;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.14.07.32;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.17.51.17;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.12.36.05;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.09.02.26;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.10.05.50;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.13.23.26;  author bayes;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.11.04.09;  author jws;  state Exp;
branches ;
next     7.2;

7.2
date     86.11.25.14.48.53;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.12.49.26;  author hal;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.16.44.29;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.14.04.45;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.18.29.21;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.11.16.29;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.14.05.54;  author hal;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.13.03.55;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@MODULE UTILITY;

IMPORT MAIN,READER,PUNCHER,SYMTABLE,LOADER,
       PASS1,SYSDEVS,FS,CI,MISC;


IMPLEMENT

PROCEDURE LPCHECK;   { USED FOR IORESULT CHECK AFTER LISTFILE OPS }
BEGIN                                           { JWS 3/2/84 }
  IF IORESULT<>0 THEN BEGIN                     { JWS 3/2/84 }
    WRITELN('ERROR WRITING LIST FILE');         { JWS 3/2/84 }
    ESCAPE(-10);                                { JWS 3/2/84 }
  END;                                          { JWS 3/2/84 }
END;                                            { JWS 3/2/84 }

PROCEDURE UPCASE(VAR X:STRING);
VAR I: SHORTINT;
BEGIN
FOR I:=1 TO LENGTH(X) DO
  IF (ORD(X[I])>=97) AND (ORD(X[I])<=122) THEN
    X[I]:=CHR(ORD(X[I])-32);
END;


FUNCTION FITSIN16{ (X: WORD32): BOOLEAN};
  BEGIN FITSIN16:=(X.LONGINT>=-32768) AND (X.LONGINT<32768) END;
FUNCTION FITSIN8{ (X: WORD32): BOOLEAN};
  BEGIN FITSIN8:=(X.LONGINT>=-128) AND (X.LONGINT<128) END;

{****** VARIOUS UTILITY PROCEDURES ******}

procedure doheader;
begin
  didheader:=true;
  with cdate do
    {LAF 880101 added "MOD 100"}
    WRITELN(LP,' PAGE',PAGENUMBER:4,' ',VERSTRING,' ',
	    MONTH:1,'/',DAY:1,'/',YEAR MOD 100:1,' ',ctimestr,' ',TITLE);
  LPCHECK;                                            { JWS 3/2/84 }
  WRITELN(LP); LPCHECK;                               { JWS 3/2/84 }

end;

PROCEDURE LISTERROR{(ER:ERRORCODE)}; { FWD }
VAR
  ES: STRING80;
BEGIN
if not didheader then
  doheader;
LISTINST(5);

IF ER = errTASwarn THEN WRITE(LP,'** WARNING ')
		   ELSE WRITE(LP,'** ERROR ');
LPCHECK;    { 3/2/84 }

IF ININCLUDE THEN
  WRITE(LP,'IN ',fibp(addr(filevar))^.ftid,' (',INCLUDELINENO:1,')')
ELSE
  WRITE(LP,'IN ',fibp(addr(filevar))^.ftid,' (',MAINLINENO:1,')');
LPCHECK;                                    { 3/2/84 }


IF (LASTERRLINE<>0) AND (ER<>errTASwarn) THEN BEGIN    { 3/2/84 }
  WRITE(LP,' SEE LINE: ',LASTERRLINE:1); LPCHECK; END; { 3/2/84 }

IF LISTNAME='CONSOLE:' THEN BEGIN WRITELN(LP); LPCHECK; END;  { 3/2/84 }
CASE ER OF
  erropen:              es:='FAILED TO RE-OPEN SOURCE FILE.';
  readerror:            es:='ERROR READING SOURCE FILE.';
  errwrite:             es:='ERROR WRITING CODE FILE.';
  errcread:             es:='ERROR READING CODE FILE.';
  erroddorg:            es:='CODE SEGMENT STARTS AT ODD ADDRESS';
  ERRBADOP:             ES:='INVALID OP CODE.';
  ERRUNDEFSYM:          ES:='UNDEFINED SYMBOL.';
  ERRBADMODE:           ES:='IMPROPER ADDRESSING MODE.';
  ERRLABELREQD:         ES:='LABEL REQUIRED.';
  ERRDUPDEFSYM:         ES:='DUPLICATE DEFINITION OF SYMBOL.';
  ERRBADSUFFIX:         ES:='IMPROPER USE OF SIZE SUFFIX.';
  ERRBADSIZE:           ES:='ILLEGAL OPERAND SIZE FOR THIS INSTRUCTION.';
  ERRBADCONST:          ES:='ILLEGAL CONSTANT.';
  ERRBADEXPR:           ES:='ILLEGAL EXPRESSION.';
  ERRARITHOFLO:         ES:='ARITHMETIC OVERFLOW.';
  ERRFIELDOFLO:         ES:='FIELD OVERFLOW.';
  ERRBADSYNTAX:         ES:='ILLEGAL SYNTAX.';
  ERRBADBASE:           ES:='EXPRESSION IS IMPROPER MODE.';
  ERREXTREFS:           ES:='EXTERNAL REFERENCE NOT ALLOWED.';
  ERRMODEDECL:          ES:='IMPROPER USE OF MODE DECLARATION.';
  ERRPHASE:             ES:='PHASE ERROR.';
  ERRINCOPEN:           ES:='FAILED TO OPEN INCLUDED FILE.';
  ERRBADINCLUDE:        ES:='ATTEMPT TO NEST INCLUDED FILES.';
  ERRBADCOM:            ES:='MORE THAN ONE COM STATEMENT.';
  ERRGOTSTART:          ES:='MORE THAN ONE START STATEMENT.';
  ERRDIROVF:            ES:='MODULE DIRECTORY OVERFLOW.';
  ERRCOMMAEXP:          ES:='COMMA EXPECTED.';
  ERRSYMBEXP:           ES:='SYMBOL EXPECTED.';
  ERREOLEXP:            ES:='BLANK OR END OF LINE EXPECTED.';
  ERRREGEXP:            ES:='REGISTER OR REGISTER LIST EXPECTED.';
  ERRAREGEXP:           ES:='ADDRESS REGISTER EXPECTED.';
  ERRCLOSEPEXP:         ES:='RIGHT PARENTHESIS EXPECTED.';
  ERRMODNAME:           ES:='MORE THAN ONE MNAME STATEMENT.';
  errTASwarn:           ES:='TAS MAY NOT BE IMPLEMENTED BY HARDWARE.';
  errlinecnt:           es:='MORE THAN 32767 LINES.';
$if mc68881$
  errfpregnotallowed:   es:='FLOATING POINT REGISTER NOT ALLOWED.';
  errfpsysregnotallowed:es:='FLOATING POINT SYSTEM REGISTER NOT ALLOWED.';
  errfpopdnotallowed:   es:='FLOATING POINT OPERAND NOT ALLOWED.';
  errdifffpregneeded:   es:='DIFFERENT FLOATING POINT REGISTERS NEEDED.';
  errfpconstneeded:     es:='FLOATING POINT CONSTANT NEEDED.';
  errfpregneeded:       es:='FLOATING POINT REGISTER NEEDED.';
  errfpsysregneeded:    es:='FLOATING POINT SYSTEM REGISTER NEEDED.';
  errfpmonadicneeded:   es:='SINGLE OPERAND INVALID ON THIS INSTRUCTION.';
  errfpel:              es:='USE OF "L" EXPONENT FLAG NOT ALLOWED.';
  errfpregexp:          es:='FLOATING POINT REGISTER (OR LIST) EXPECTED.';
  errbadfpk:            es:='INVALID FLOATING POINT BCD "K-FACTOR".';
  errfpromconst:        es:='INVALID FLOATING POINT ROM CONSTANT ADDRESS.';
  errfpimmedparse:      es:='INVALID FLOATING POINT IMMEDIATE OPERAND.';
  errfpimmedsize:       es:='FLOATING POINT IMMEDIATES MUST BE SIZE ".D".';
  errfpbccsize:         es:='32 BIT FBcc DISPLACEMENTS NOT SUPPORTED.';

  errfpinternalerr:     es:='INTERNAL ASSEMBLER ERROR.';

$end$
  ERRCOLONEXP:          ES:='(":") COLON EXPECTED.';
  ERRLBRACEEXP:         ES:='("{") LEFT BRACE EXPECTED.';
  ERRRBRACEEXP:         ES:='("}") RIGHT BRACE EXPECTED.';
  ERRRBRACKEXP:         ES:='("]") RIGHT BRACKET EXPECTED.';
  ERRRBRACKUNEXP:       ES:='("]") RIGHT BRACKET UNEXPECTED.';
  ERR2INNER:            ES:='TOO MANY INNER EXPRESSIONS.';
  ERR2DISP:             ES:='TOO MANY DISPLACEMENTS.';
  ERR2INDEX:            ES:='TOO MANY INDEXES.';
  ERR2AN:               ES:='TOO MANY ADDRESS REGISTERS.';
  ERR2ZPC:              ES:='TOO MANY ZPC''S.';
  ERRMISZPC:            ES:='MISPLACED ZPC.';
  ERRBADSCALE:          ES:='IMPROPER SCALE.';
  ERRRELREFS:           ES:='RELATIVE REFERENCE NOT ALLOWED.';
  END;
IF LISTNAME='CONSOLE:' THEN LISTINST(5);
WRITELN(LP,'  ',ES);
LPCHECK;                   { 3/2/84 }


IF ER <> ERRTASWARN THEN
  BEGIN
    LASTERRLINE:=LINENO;
    ERRCOUNT:=ERRCOUNT+1;
  END;

END;


PROCEDURE ERROR (* ER: ERRORCODE *); {FWD}
VAR
  NUMLEFT: SHORTINT;
  stemp: lstring;

BEGIN
IF (PASS=1) OR (NOT (LISTING AND SUPERLIST)) THEN
  BEGIN
    stemp:=printline;
    if not didheader then
      doheader;
    LISTINST(5);
    WRITE(LP, LINENO:5, ' ');
    LPCHECK;                                            { JWS 3/2/84 }
    NUMLEFT:=LLEN-6;
    if (currop.name='DC       ') and  (printline='') then
       printline:=line;
    IF NUMLEFT>=LENGTH(PRINTLINE) THEN
       WRITELN(LP,PRINTLINE)
    ELSE
      WRITELN(LP,COPY(PRINTLINE,1,NUMLEFT));
    LPCHECK;                                            { JWS 3/2/84 }
    LISTERROR(ER);
    printline:=stemp;
  END
ELSE
  IF NOT ERRINLINE THEN BEGIN
    ERRINLINE:=TRUE;
    LINEERRCODE:=ER;
  END
END;



FUNCTION MEMALT{ (OP:OPERAND): BOOLEAN };   {FWD}
{ DETERMINES IF AN OPERAND IS MEMORY ALTERABLE }
BEGIN
  IF ((OP.MODE>1) AND (OP.MODE<7)) OR
     ((OP.MODE=7) AND (OP.REG<=1))
       THEN MEMALT:=TRUE
       ELSE MEMALT:=FALSE
END;

FUNCTION ALTERABLE{ (OP: OPERAND): BOOLEAN};  { FWD DECLARED }
{ DETERMINES IF AN OPERAND IS IN THE ALTERABLE CLASS }
BEGIN
$if not mc68881$
IF OP.MODE<7 THEN ALTERABLE:=TRUE
ELSE IF OP.REG<2 THEN ALTERABLE:=TRUE
       ELSE ALTERABLE:=FALSE;
$end$
$if mc68881$
if (op.mode < 7) or (op.mode = 8) then alterable := true
else
  if (op.mode = 7) and (op.reg < 2) then alterable := true
  else
    if (op.mode = 9) and (op.reg <= 2) then alterable := true
    else
      alterable := false;
$end$
END;

FUNCTION DATALTERABLE{ (OP: OPERAND): BOOLEAN};  { FWD DECLARED }
{ DETERMINES IF AN OPERAND IS IN THE DATA ALTERABLE CLASS }
BEGIN
IF (OP.MODE<7) AND (OP.MODE<>1) THEN DATALTERABLE:=TRUE
ELSE IF (OP.MODE=7) AND (OP.REG<2) THEN DATALTERABLE:=TRUE
$if mc68881$
else if (op.mode = 8 ) then datalterable := true
$end$
       ELSE DATALTERABLE:=FALSE;
END;

FUNCTION CONTROLALTERABLE{ (OP: OPERAND): BOOLEAN};  { FWD DECLARED }
{ DETERMINES IF AN OPERAND IS IN THE CONTROL AND ALTERABLE CLASSES }
BEGIN
CONTROLALTERABLE:=(OP.MODE=2) OR (OP.MODE=5) OR (OP.MODE=6) OR
		 ((OP.MODE=7) AND (OP.REG<=1));
END;

FUNCTION CONTROLMODE{(OP: OPERAND): BOOLEAN};  { FWD DECLARED}
BEGIN
IF ((OP.MODE<=4) AND (OP.MODE<>2)) OR
   ((OP.MODE=7) AND (OP.REG=4)) THEN
     CONTROLMODE:=FALSE
$if mc68881$
else if ( op.mode = 8 ) then controlmode := false
$end$
ELSE CONTROLMODE:=TRUE;
END;

FUNCTION DATAMODE{(OP:OPERAND): BOOLEAN};  { FWD DECLARED }
BEGIN
IF (OP.MODE<>1) AND NOT((OP.MODE=7)AND (OP.REG>4)) THEN
  DATAMODE:=TRUE
ELSE DATAMODE:=FALSE;
END;


$if mc68881$
function memmode (* ( opd : operand ) : boolean *);     (* fwd declared *)
begin
  if (opd.mode > 1) and (opd.mode < 7) then
    memmode := true
  else
    if (opd.mode = 7) and (opd.reg <= 4) then
      memmode := true
    else
      memmode := false;
end;
$end$


PROCEDURE LISTINST{FHTCODE:SHORTINT};  { FWD DECLARED }
TYPE HDIGITS=PACKED ARRAY[1..16] OF CHAR;

VAR IDX,LINESREQ:SHORTINT;
    C1,C2: CHAR;
    HEX: HDIGITS;
    NUMLEFT: SHORTINT;
    I: SHORTINT;



PROCEDURE ITOHEX(INUM:SHORTINT);
BEGIN
  C1:=HEX[INUM DIV 16 + 1];
  C2:=HEX[INUM MOD 16 + 1];
END;

PROCEDURE NEWPAGE;
VAR I:SHORTINT;
  BEGIN
    PAGENUMBER:=PAGENUMBER+1;
    page(LP);
    LPCHECK;                                      { JWS 3/2/84 }
    FOR I:=1 TO TOPMARGIN DO BEGIN WRITELN(LP); LPCHECK; END;  { 3/2/84 }
    WITH CDATE DO
      {LAF 880101 added "MOD 100"}
      WRITELN(LP,' PAGE',PAGENUMBER:4,' ',VERSTRING,' ',
	MONTH:1,'/',DAY:1,'/',YEAR MOD 100:1,' ',ctimestr,' ',TITLE);
    LPCHECK;                                                   { JWS 3/2/84 }
    WRITELN(LP);
    LPCHECK;                                                   { JWS 3/2/84 }
    CURRENTLINE:=TOPMARGIN+2;
  END;


PROCEDURE LISTPC;
  BEGIN
    if decimal then BEGIN write(lp,locctr.longint:11); LPCHECK; END { 3/2/84}
    else begin
      write(lp,' ':3);
      LPCHECK;                                               { JWS 3/2/84 }
      ITOHEX(LOCCTR.BYTE1);WRITE(LP,C1,C2);
      LPCHECK;                                               { JWS 3/2/84 }
      ITOHEX(LOCCTR.BYTE2);WRITE(LP,C1,C2);
      LPCHECK;                                               { JWS 3/2/84 }
      ITOHEX(LOCCTR.BYTE3);WRITE(LP,C1,C2);
      LPCHECK;                                               { JWS 3/2/84 }
      ITOHEX(LOCCTR.BYTE4);WRITE(LP,C1,C2);
      LPCHECK;                                               { JWS 3/2/84 }
    end;
    WRITE(LP,' ');
    LPCHECK;                                               { JWS 3/2/84 }
  END;


PROCEDURE LISTCODE(IDX:SHORTINT);
  BEGIN
    IF IDX>CODELENGTH THEN WRITE(LP,'  ')
       ELSE BEGIN                                          { JWS 3/20/84 }
	 ITOHEX(CODE.BYT[IDX]);WRITE(LP,C1,C2); END;       { JWS 3/20/84 }
    LPCHECK;                                               { JWS 3/2/84 }
  END;

(* LIST INSTRUCTION AND SOURCE LINE *)
BEGIN
  HEX:='0123456789ABCDEF';
  IF (SUPERLIST AND LISTING) OR (FHTCODE=5)  THEN
    BEGIN
$if mc68881$
  if fhtcode > 2 then
    linesreq := 1
  else
    linesreq := 1 + ord( codelength > 4 ) + ord( codelength > 8 )
		+ ord( codelength > 12 );
$end$
$if not mc68881$
  IF FHTCODE>2 THEN LINESREQ:=1 ELSE LINESREQ:=1+ORD(CODELENGTH>4);
$end$
  IF (LINESREQ+CURRENTLINE)>(LINESPERPAGE-BOTMARGIN) THEN NEWPAGE;
  CURRENTLINE:=CURRENTLINE+LINESREQ;
  IF FHTCODE<5 THEN
    BEGIN
      WRITE(LP,LINENO:5); LPCHECK; WRITE(LP,' ');       { JWS 3/2/84 }
      LPCHECK;                                          { JWS 3/2/84 }
      CASE FHTCODE OF
      1: (* NORMAL LINE *) BEGIN LISTPC;LISTCODE(1);LISTCODE(2);
	 WRITE(LP,' '); LPCHECK; LISTCODE(3); LISTCODE(4); END;  { JWS 3/2/84 }
      2: (* NO PC *) BEGIN WRITE(LP,' ':12); LPCHECK;            { JWS 3/2/84 }
	 LISTCODE(1);LISTCODE(2);
	 WRITE(LP,' '); LPCHECK; LISTCODE(3); LISTCODE(4) END;   { JWS 3/2/84 }
      3: (* NO CODE *) BEGIN LISTPC;WRITE(LP,' ':9);LPCHECK; END; { JWS 3/2/84 }
      4: (* NO PC OR CODE *) BEGIN WRITE(LP,' ':21);LPCHECK;END;  { JWS 3/2/84 }
      END;
      NUMLEFT:=LLEN-28;
      IF NUMLEFT>=LENGTH(PRINTLINE) THEN
	WRITELN(LP,' ',PRINTLINE)
      ELSE
	WRITELN(LP,' ',COPY(PRINTLINE,1,NUMLEFT));
      LPCHECK;                                                 { JWS 3/2/84 }
      IF FHTCODE<3 THEN
	IF CODELENGTH>4 THEN
	  BEGIN
	    IDX:=5;
	    WRITE(LP,' ':18);
	    LPCHECK;                                            { JWS 3/2/84 }
	    REPEAT
	      BEGIN
	      LISTCODE(IDX);LISTCODE(IDX+1);WRITE(LP,' ');
	      LPCHECK;                                          { JWS 3/2/84 }
	    IDX:=IDX+2;
	      END;
	    UNTIL IDX>CODELENGTH;
	    WRITELN(LP);
	    LPCHECK;                                            { JWS 3/2/84 }
	  END;
    END;
  END;
END;

PROCEDURE INTERPASS{WHICH: SHORTINT};
  var
    i: integer;
    seconds: shortint;

  PROCEDURE INITLIBDIR;   { INITIALIZE LIBRARY DIRECTORY }
   VAR I: SHORTINT;
  BEGIN
  FOR I:=0 TO 511 DO PUNCHBLK[I]:=0;
  LDIRP:=LDIRPTRTYPE(ADDR(PUNCHBLK));
  WITH LDIRP^[0] DO BEGIN
    DFIRSTBLK:=0;
    DLASTBLK:=1;
    DFKIND:=UNTYPEDFILE;
    DVID:='LIB';
    DEOVBLK:=1;
    DNUMFILES:=1;
    DLOADTIME:=0;
    DLASTBOOT:=CDATE;
  END;
  WITH LDIRP^[1] DO BEGIN
    DFIRSTBLK:=1;
    DLASTBLK:=0;   { TO FILL IN LATER }
    DFKIND:=CODEFILE;
    DTID:=MODNAME;
    DLASTBYTE:=1;
    DACCESS:=CDATE;
  END;
  if object then begin
    I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1,0);
    IF I<>1 THEN ERROR(errwrite);
  end;
  END;  { OF PROCEDURE }

  PROCEDURE INITIALIZEMD;
    VAR I: SHORTINT;
  BEGIN
  FOR I:=0 TO 511 DO PUNCHBLK[I]:=0;
  MDPTR:=MDPTRTYPE(ADDR(PUNCHBLK));
  WITH MDPTR^ DO BEGIN
    DATE:=CDATE;
    REVISION:=RDATE;
    PRODUCER:='A';
    SYSTEMID:=ord(verstring[2]) - ord('0');
    NOTICE:='';
  END;
  TEXTINFO:=SIZEOF(MODULEDIRECTORY);   { INITIAL BYTE OFFSET FOR THIS }
  if object then begin
    I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1,1);
    IF I<>1 THEN ERROR(errwrite);
  end;
  END;

  PROCEDURE INSERTMODNAME;
  VAR I: INTEGER;
  BEGIN
  PUNCHLC:=TEXTINFO;
  if object then begin
    I:=BLOCKREAD(OBJFILE,PUNCHBLK,1,1);
    IF I<>1 THEN ERROR(errcread);
  end;
  FOR I:=0 TO LENGTH(MODNAME) DO
    PUNCHBYTE(ORD(MODNAME[I]));
  IF ODD(PUNCHLC) THEN PUNCHLC:=PUNCHLC+1;
  TEXTINFO:=PUNCHLC;
  if object then begin
    I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1,1);
    IF I<>1 THEN ERROR(errwrite);
  end;
  END;

  PROCEDURE DOCLEANUP;  { FILL IN DIRECTORY HOLES}
  VAR LENGTH: INTEGER;
      OVID: VID;
      OTID: TID;
      I: INTEGER;
      KIND: FILEKIND;


  BEGIN
  IF CONTIGUOUS THEN
    TEXTSIZE:=LOCCTR.LONGINT-ORIGIN
  ELSE
     TEXTSIZE:=ENDOFCODE-ORIGIN;
  if object then begin
    I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1, OBJCTR); { OUTPUT LAST BLOCK}
    IF I<>1 THEN listerror(errwrite);
    I:=BLOCKREAD(OBJFILE,PUNCHBLK,1,1); { GET MODULE DIR. BLOCK}
    IF I<>1 THEN listerror(errcread);
  end;
  PUNCHLC:=TEXTINFO;
  IF PUNCHLC+22>511 THEN listerror(ERRDIROVF);
  PUNCHDWORD(TEXTSTART);
  PUNCHDWORD(TEXTSIZE);
  PUNCHDWORD(REFSTART);
  PUNCHDWORD(REFSIZE);
  IF PCMODE=REL THEN GV.PRIMARYTYPE:=RELOCATABLE
    ELSE GV.PRIMARYTYPE:=ABSOLUTE;
  GV.DATASIZE:=SINT;
  GV.PATCHABLE:=FALSE;
  GV.VALUEEXTEND:=TRUE;
  GV.LONGOFFSET:=FALSE;
  GV.SHORT:=6;
  PUNCHGVR(GV);
  PUNCHDWORD(ORIGIN);
  MDPTR:=MDPTRTYPE(ADDR(PUNCHBLK));
  MDPTR^.MODULESIZE:=OBJCTR*512;
  if pcmode=rel then
    if locctr.longint > highaddr.longint then highaddr:=locctr;
  MDPTR^.RELOCATABLESIZE:=highaddr.longint-lowrorg.longint;
  MDPTR^.RELOCATABLEBASE:=LOWRORG.LONGINT;
  MDPTR^.GLOBALSIZE:=GLOBALSIZE;
  MDPTR^.GLOBALBASE:=GLOBALBASE;
  MDPTR^.DIRECTORYSIZE:=PUNCHLC;
  MDPTR^.TEXTRECORDS:=TEXTRECORDS+1;
  MDPTR^.EXTBLOCK:=EXTSTART;
  MDPTR^.EXTSIZE:=EXTSIZE;
  MDPTR^.DEFBLOCK:=DEFSTART;
  MDPTR^.DEFSIZE:=DEFSIZE;
  MDPTR^.SOURCEBLOCK:=SOURCESTART;
  MDPTR^.SOURCESIZE:=SOURCESIZE;
  if object then begin
    I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1,1);
    IF I<>1  THEN listerror(errwrite);
    I:=BLOCKREAD(OBJFILE, PUNCHBLK,1,0);
    IF I<>1 THEN listerror(errcread);
  end;
  LDIRP:=LDIRPTRTYPE(ADDR(PUNCHBLK));
  LDIRP^[1].DLASTBLK:=OBJCTR+1;
  if object then begin
    I:=BLOCKWRITE(OBJFILE, PUNCHBLK, 1, 0);
    IF I<>1 THEN listerror(errwrite);
    CLOSE(OBJFILE,'LOCK');
    IF IORESULT<>0 THEN listerror(errwrite);
  end
  else close(objfile,'PURGE');
  IF (PASS1ERRS=0) AND (ERRCOUNT=0) THEN BEGIN
   USERINFO^.GOTCODE:=TRUE;
   USERINFO^.CODEFID:=OBJNAME;
  END;
  END;


  PROCEDURE INITFILES;
  LABEL 1,2;
  VAR I,J: SHORTINT;
      defaultlistfile,
      DEFAULTFILENAME: STRING80;

    function getfid(s: fid): fid;
      begin
      if suffix(s) <> datafile then
	begin
	i := strlen(s);
	while s[i] <> '.' do
	  i := i - 1;
	getfid := str(s,1,i-1);
	end
      else
	getfid := s;
      end;

    BEGIN
      SUPERLIST:=FALSE;
      DOREAD;      { INITIALIZE SOURCE INPUT }
      IF USERINFO^.GOTSYM THEN BEGIN
	LAB:='CONSOLE:';
	REWRITE(LP,LAB);
      END
      ELSE BEGIN
1:      LAB:='';
	SUPERLIST:=FALSE;
	REPEAT
	  WRITE('Do you want a program listing (y/n/e) ? ');
	  READ(REPLY);
	  WRITELN;
	  IF STREAMING AND NOT(REPLY IN ['y','Y','e','E','n','N'])
	    THEN BEGIN
	      WRITELN('Bad response to "program listing" query!');
	      ESCAPE(-1);
	  END;
	UNTIL REPLY IN ['Y','y','N','n','E','e'];
	IF (REPLY='Y') OR (REPLY='y') THEN SUPERLIST:=TRUE;
	IF (REPLY='N') OR (REPLY='n') THEN begin
	   superlist:=false;
	  LAB:='CONSOLE:'
	end
	ELSE BEGIN
	  defaultlistfile := 'PRINTER:' +
	    getfid(fibp(addr(filevar))^.ftid) + '.ASC';
	  WRITE('What listing file (default ',defaultlistfile,') ? ');
	  READLN(LAB);
	  fixname(lab,textfile);
	  IF LAB='' THEN LAB:=defaultlistfile;
	END;
	REWRITE(LP,LAB);
	IF IORESULT<>0 THEN BEGIN
	  I:=IORESULT;
	  getioerrmsg(iomsg, i);
	  writeln('Error: ',iomsg);
	  IF STREAMING THEN ESCAPE(-1) ELSE GOTO 1;
	END;
      END;
      LISTNAME:=LAB;
      defaultfilename := getfid(sourcefilename) + '.CODE';
      IF USERINFO^.GOTSYM THEN
	OBJNAME:=DEFAULTFILENAME
      ELSE BEGIN
2:      WRITE('Output file (default is ',DEFAULTFILENAME,') ? ');
	READLN(OBJNAME);
	fixname(objname,codefile);
	IF OBJNAME='' THEN
	  OBJNAME:=DEFAULTFILENAME;
      END;
      REWRITE(OBJFILE, OBJNAME);
      I:=IORESULT;
      IF I<>0 THEN BEGIN
	getioerrmsg(iomsg,i);
	writeln('Error: ',iomsg);
	IF STREAMING THEN ESCAPE(-1) else goto 2;
      END;
      MODNAME:=getfid(fibp(addr(filevar))^.ftid);
      if strlen(modname) > 15 then
	setstrlen(modname,15);
    END;

  PROCEDURE INITABLES;
    VAR CH:CHAR;
    BEGIN
      ZERO32.HIHALF:=0; ZERO32.LOHALF:=0;
      FOR CH:=CHR(0) TO CHR(255) DO
	BEGIN XLATE[CH]:=CH; CHTYPE[CH]:=SPECIAL END;
      FOR CH:='A' TO 'Z' DO CHTYPE[CH]:=ALPHABETIC;
      FOR CH:='a' TO 'z' DO
	BEGIN
	  CHTYPE[CH]:=ALPHABETIC;
	  XLATE[CH]:=CHR(ORD(CH)-ORD('a')+ORD('A'))
	END;
      CHTYPE['_']:=ALPHABETIC; CHTYPE['@@']:=ALPHABETIC;
      CHTYPE['$']:=ALPHABETIC; { CHTYPE[':']:=ALPHABETIC;  NO!  NO!  NO! }
      FOR CH:='0' TO '9' DO CHTYPE[CH]:=NUMERIC;
      DOSYMS;  {INITIALIZE SYMBOL TABLE HASH}

      LAB:='D0'; STDSYM(0,DREG);
      LAB:='D1'; STDSYM(1,DREG);
      LAB:='D2'; STDSYM(2,DREG);
      LAB:='D3'; STDSYM(3,DREG);
      LAB:='D4'; STDSYM(4,DREG);
      LAB:='D5'; STDSYM(5,DREG);
      LAB:='D6'; STDSYM(6,DREG);
      LAB:='D7'; STDSYM(7,DREG);

      LAB:='A0'; STDSYM(0,AREG);
      LAB:='A1'; STDSYM(1,AREG);
      LAB:='A2'; STDSYM(2,AREG);
      LAB:='A3'; STDSYM(3,AREG);
      LAB:='A4'; STDSYM(4,AREG);
      LAB:='A5'; STDSYM(5,AREG);
      LAB:='A6'; STDSYM(6,AREG);
      LAB:='A7'; STDSYM(7,AREG);
      LAB:='SP'; STDSYM(7,AREG);

      LAB:='CCR';  STDSYM( 5,STREG);
      LAB:='SR';   STDSYM( 6,STREG);
      LAB:='USP';  STDSYM( 7,STREG);
      LAB:='DFC';  STDSYM( 8,STREG);
      LAB:='SFC';  STDSYM( 9,STREG);
      LAB:='VBR';  STDSYM(10,STREG);
      LAB:='MSP';  STDSYM(11,STREG);
      LAB:='ISP';  STDSYM(12,STREG);
      LAB:='CACR'; STDSYM(13,STREG);
      LAB:='CAAR'; STDSYM(14,STREG);
{ Added for the new '040 registers JWH 12/26/89 : }
      LAB:='TC'; STDSYM(15,STREG);
      LAB:='ITT0'; STDSYM(16,STREG);
      LAB:='ITT1'; STDSYM(17,STREG);
      LAB:='DTT0'; STDSYM(18,STREG);
      LAB:='DTT1'; STDSYM(19,STREG);
      LAB:='MMUSR'; STDSYM(20,STREG);
      LAB:='URP'; STDSYM(21,STREG);
      LAB:='SRP'; STDSYM(22,STREG);
$if mc68881$
      lab := 'FP0'; stdsym( 0, fpreg );
      lab := 'FP1'; stdsym( 1, fpreg );
      lab := 'FP2'; stdsym( 2, fpreg );
      lab := 'FP3'; stdsym( 3, fpreg );
      lab := 'FP4'; stdsym( 4, fpreg );
      lab := 'FP5'; stdsym( 5, fpreg );
      lab := 'FP6'; stdsym( 6, fpreg );
      lab := 'FP7'; stdsym( 7, fpreg );
      lab := 'FPCONTROL'; stdsym( 0, fpstreg );
      lab := 'FPSTATUS';  stdsym( 1, fpstreg );
      lab := 'FPIADDR';   stdsym( 2, fpstreg );
$end$
      LAB:='ZPC';  STDSYM(16,PREG);
    END;

  PROCEDURE INSERTSTART;
  VAR I: SHORTINT;
  BEGIN
    if object then begin
      I:=BLOCKREAD(OBJFILE, PUNCHBLK, 1,1);
      IF I<>1 THEN ERROR(errcread);
    end;
    PUNCHLC:=TEXTINFO;
    MDPTR:=MDPTRTYPE(ADDR(PUNCHBLK));
    MDPTR^.EXECUTABLE:=TRUE;
    GV.PRIMARYTYPE:=STARTMODE;
    GV.DATASIZE:=SINT;
    GV.PATCHABLE:=FALSE;
    GV.VALUEEXTEND:=TRUE;
    GV.LONGOFFSET:=FALSE;
    GV.SHORT:=6;
    PUNCHGVR(GV);
    PUNCHDWORD(STARTLOC.LONGINT);
    TEXTINFO:=PUNCHLC;
    if object then begin
      I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1,1);
      IF I<>1 THEN ERROR(errwrite);
    end;
    END;

  PROCEDURE COPYSOURCE;

  VAR TEMPSOURCE: SOURCEPTR;
      I: SHORTINT;
      N: SHORTINT;  { USED TO COUNT PAGES }


  BEGIN
    IF SOURCEHEAD<>NIL THEN BEGIN
      IF (PUNCHLC<>0) THEN ENDBLOCK;
      SOURCESTART:=OBJCTR-1;
      SOURCESIZE:=0;
      N:=0;
      TEMPSOURCE:=SOURCEHEAD;
      WHILE TEMPSOURCE<>NIL DO BEGIN
	IF (LENGTH(TEMPSOURCE^.SOURCELINE) + PUNCHLC+ORD(ODD(N))) > 511 THEN
	  IF ODD(N) THEN BEGIN   { NEW PAGE }
	    FOR I:=PUNCHLC TO 511 DO PUNCHBLK[I]:=0;
	    if object then begin
	      I:=BLOCKWRITE(OBJFILE, PUNCHBLK, 1, OBJCTR);
	      IF I<>1 THEN listerror(errwrite);
	    end;
	    OBJCTR:=OBJCTR+1;
	    N:=N+1;
	    PUNCHLC:=0;
	  END
	  ELSE N:=N+1;
	FOR I:=1 TO LENGTH(TEMPSOURCE^.SOURCELINE) DO
	  PUNCHBYTE(ORD(TEMPSOURCE^.SOURCELINE[I]));
	PUNCHBYTE(13);  { PUT OUT A CR }
	TEMPSOURCE:=TEMPSOURCE^.NEXTSOURCE;
      END;
      IF ODD(N) THEN BEGIN
	PUNCHBLK[PUNCHLC]:=3;
	FOR I:=(PUNCHLC+1) TO 511 DO PUNCHBLK[I]:=0;
	SOURCESIZE:=(N+1)*512;
	PUNCHLC:=511;
      END
      ELSE IF PUNCHLC>0 THEN BEGIN
	PUNCHBLK[PUNCHLC]:=3;
	FOR I:=(PUNCHLC+1) TO 511 DO PUNCHBLK[I]:=0;
	if object then begin
	  I:=BLOCKWRITE(OBJFILE, PUNCHBLK, 1, OBJCTR);
	  IF I<>1 THEN listerror(errwrite);
	end;
	OBJCTR:=OBJCTR+1;
	PUNCHLC:=511;
	FOR I:=0 TO 511 DO PUNCHBLK[I]:=0;
	SOURCESIZE:=(N+2)*512
      END
    END
  END;

  BEGIN { BODY OF INTERPASS }
    CASE WHICH OF
      1: BEGIN
	   PASS:=1;
	   didheader:=false;
	   listdone:=false;
	   decimal:=false;
	   OBJECT:=TRUE;
	   GOTSTART:=FALSE;
	   GOTMODNAME:=FALSE;
	   GOTCOM:=FALSE;
	   MODNAME:='';
	   RDATE.MONTH:=MONTH;
	   RDATE.DAY:=DAY;
	   RDATE.YEAR:=YEAR;
	   systime(ctime);
	   setstrlen(ctimestr,0);
	   i := 1;
	   if ctime.hour < 10 then
	     strwrite(ctimestr,i,i,'0');
	   strwrite(ctimestr,i,i,ctime.hour:1,':');
	   if ctime.minute < 10 then
	     strwrite(ctimestr,i,i,'0');
	   strwrite(ctimestr,i,i,ctime.minute:1,':');
	   seconds := ctime.centisecond div 100;
	   if seconds < 10 then
	     strwrite(ctimestr,i,i,'0');
	   strwrite(ctimestr,i,i,seconds:1);
	   SYSDATE(CDATE);
	   with cdate do
	   {LAF 880101 added "mod 100"'s}
	   writeln('Assembler [ Rev ',copy(verstring,
		   2,strlen(verstring)-2),' ',rdate.month:1,'/',rdate.day:1,'/',
		   rdate.year mod 100:1,' ] ',
		   month:1,'/',day:1,'/',year mod 100:1,' ',ctimestr);
	   writeln;
	   writeln('Copyright Hewlett-Packard Company, 1982, 1991.');
	   writeln('           All rights reserved.');
	   writeln;
	   EXTHEAD:=NIL; EXTTAIL:=NIL;
	   DEFHEAD:=NIL; DEFTAIL:=NIL;
	   REFHEAD:=NIL; REFTAIL:=NIL;
	   SOURCEHEAD:=NIL; SOURCETAIL:=NIL;
	   OPERAND1.VALUE.EXPREFS:=NIL;
	   OPERAND2.VALUE.EXPREFS:=NIL;
	   OPERAND3.VALUE.EXPREFS:=NIL;
	   OPERAND4.VALUE.EXPREFS:=NIL;
	   OPERAND5.VALUE.EXPREFS:=NIL;
	   OPERAND6.VALUE.EXPREFS:=NIL;
	   LASTERRLINE:=0;
	   LISTING:=TRUE;
	   PAGENUMBER:=1;
	   TOPMARGIN:=1;
	   BOTMARGIN:=6;
	   CURRENTLINE:=2;
	   LINESPERPAGE:=66;
	   LLEN:=132;
	   ERRCOUNT:=0;
	   INITFILES;
	   INITABLES;
	   TITLE:=CONCAT(' ASSEMBLY OF ',fibp(addr(filevar))^.ftid);
	   GLOBALSIZE:=0;
	   GLOBALBASE:=0;
	   EXTCTR:=0;
	   EXTSIZE:=8;
	   DEFCTR:=0;
	   REFCTR:=0;
	   SOURCESTART:=0;
	   SOURCESIZE:=0;
	   LOCCTR:=ZERO32;
	   PCMODE:=REL;
	   ORGMODE:=SHORTFWDS;
	   LISTSYMS:=TRUE;
	   if superlist then
	     doheader;
	 END;

      2: BEGIN
	 llen:=132;
	 CONTIGUOUS:=TRUE;
	 INITLIBDIR;
	 INITIALIZEMD;
	 INSERTMODNAME;
	 IF GOTSTART THEN INSERTSTART;
	 OBJCTR:=2;
	 TEXTSTART:=1;
	 TEXTRECORDS:=0;
	 FIRSTREF:=TRUE;
	 PUNCHLC:=0;
	 if didheader and  (listname<>'CONSOLE:') then BEGIN  { 3/2/84 }
	      WRITELN(LP,'PASS 1 COMPLETE. ERRORS: ', ERRCOUNT:1);
	      LPCHECK;                                        { 3/2/84 }
	 END;                                                 { 3/2/84 }
	 if listname<>'CONSOLE:' then BEGIN                   { 3/2/84 }
	      writeln('PASS 1 COMPLETE. ERRORS: ', errcount:1);
	      LPCHECK;                                        { 3/2/84 }
	  END;                                                { 3/2/84 }
	 PASS1ERRS:=ERRCOUNT;
	 PASS:=2;
	 SHORTMODE:=FALSE;
	 LASTERRLINE:=0;
	 ERRINLINE:=FALSE;
	 ERRCOUNT:=0;
	 ORIGIN:=0;
	 LOCCTR:=ZERO32;
	 HIGHADDR:=ZERO32;
	 LOWRORG.LOHALF:=-1;
	 LOWRORG.HIHALF:=-1;
	 PCMODE:=REL;
	 ORGMODE:=SHORTFWDS;
	 TRY OPENINPUT  {RE-OPEN THE SOURCE FILE}
	   RECOVER ESCAPE(-1);
	 END;

      3: BEGIN
	 listdone:=true;
	 IF (LOWRORG.LOHALF=-1) AND (LOWRORG.HIHALF=-1) THEN LOWRORG:=ZERO32;
	 REFCOPY;
	 COPYLINKS;
	 COPYSOURCE;
	 DOCLEANUP;
	 if didheader or (listname='CONSOLE:') then begin
	   LISTINST(5);
	   WRITELN(LP,'PASS 1 ERRORS: ', PASS1ERRS:1);
	   LPCHECK;                                          { JWS 3/2/84 }
	   LISTINST(5);
	   LPCHECK;                                          { JWS 3/2/84 }
	   WRITE(LP,'PASS 2 ERRORS: ',ERRCOUNT:1);
	   LPCHECK;                                          { JWS 3/2/84 }
	 end;
	 IF LISTNAME<>'CONSOLE:' THEN
	   WRITELN('PASS 2 COMPLETE. ERRORS: ',ERRCOUNT:1);
	 IF ERRCOUNT<>0 THEN BEGIN
	   WRITELN(LP,'  SEE LINE: ',LASTERRLINE:1);
	   LPCHECK;                                          { 3/2/84 }
	 END                                                 { 3/2/84 }
	   else if didheader then BEGIN writeln(lp); LPCHECK; END; { 3/2/84 }
	 IF SUPERLIST AND LISTSYMS THEN BEGIN
	   CURRENTLINE:=70;
	   LISTINST(5);
	   DUMPTABLE;
	 END
       END;
    END
  END;   { INTERPASS }

 { UTILITY MODULE } END;



@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 908
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 908
MODULE UTILITY;

IMPORT MAIN,READER,PUNCHER,SYMTABLE,LOADER,
       PASS1,SYSDEVS,FS,CI,MISC;


IMPLEMENT

PROCEDURE LPCHECK;   { USED FOR IORESULT CHECK AFTER LISTFILE OPS }
BEGIN                                           { JWS 3/2/84 }
  IF IORESULT<>0 THEN BEGIN                     { JWS 3/2/84 }
    WRITELN('ERROR WRITING LIST FILE');         { JWS 3/2/84 }
    ESCAPE(-10);                                { JWS 3/2/84 }
  END;                                          { JWS 3/2/84 }
END;                                            { JWS 3/2/84 }

PROCEDURE UPCASE(VAR X:STRING);
VAR I: SHORTINT;
BEGIN
FOR I:=1 TO LENGTH(X) DO
  IF (ORD(X[I])>=97) AND (ORD(X[I])<=122) THEN
    X[I]:=CHR(ORD(X[I])-32);
END;


FUNCTION FITSIN16{ (X: WORD32): BOOLEAN};
  BEGIN FITSIN16:=(X.LONGINT>=-32768) AND (X.LONGINT<32768) END;
FUNCTION FITSIN8{ (X: WORD32): BOOLEAN};
  BEGIN FITSIN8:=(X.LONGINT>=-128) AND (X.LONGINT<128) END;

{****** VARIOUS UTILITY PROCEDURES ******}

procedure doheader;
begin
  didheader:=true;
  with cdate do
    {LAF 880101 added "MOD 100"}
    WRITELN(LP,' PAGE',PAGENUMBER:4,' ',VERSTRING,' ',
	    MONTH:1,'/',DAY:1,'/',YEAR MOD 100:1,' ',ctimestr,' ',TITLE);
  LPCHECK;                                            { JWS 3/2/84 }
  WRITELN(LP); LPCHECK;                               { JWS 3/2/84 }

end;

PROCEDURE LISTERROR{(ER:ERRORCODE)}; { FWD }
VAR
  ES: STRING80;
BEGIN
if not didheader then
  doheader;
LISTINST(5);

IF ER = errTASwarn THEN WRITE(LP,'** WARNING ')
		   ELSE WRITE(LP,'** ERROR ');
LPCHECK;    { 3/2/84 }

IF ININCLUDE THEN
  WRITE(LP,'IN ',fibp(addr(filevar))^.ftid,' (',INCLUDELINENO:1,')')
ELSE
  WRITE(LP,'IN ',fibp(addr(filevar))^.ftid,' (',MAINLINENO:1,')');
LPCHECK;                                    { 3/2/84 }


IF (LASTERRLINE<>0) AND (ER<>errTASwarn) THEN BEGIN    { 3/2/84 }
  WRITE(LP,' SEE LINE: ',LASTERRLINE:1); LPCHECK; END; { 3/2/84 }

IF LISTNAME='CONSOLE:' THEN BEGIN WRITELN(LP); LPCHECK; END;  { 3/2/84 }
CASE ER OF
  erropen:              es:='FAILED TO RE-OPEN SOURCE FILE.';
  readerror:            es:='ERROR READING SOURCE FILE.';
  errwrite:             es:='ERROR WRITING CODE FILE.';
  errcread:             es:='ERROR READING CODE FILE.';
  erroddorg:            es:='CODE SEGMENT STARTS AT ODD ADDRESS';
  ERRBADOP:             ES:='INVALID OP CODE.';
  ERRUNDEFSYM:          ES:='UNDEFINED SYMBOL.';
  ERRBADMODE:           ES:='IMPROPER ADDRESSING MODE.';
  ERRLABELREQD:         ES:='LABEL REQUIRED.';
  ERRDUPDEFSYM:         ES:='DUPLICATE DEFINITION OF SYMBOL.';
  ERRBADSUFFIX:         ES:='IMPROPER USE OF SIZE SUFFIX.';
  ERRBADSIZE:           ES:='ILLEGAL OPERAND SIZE FOR THIS INSTRUCTION.';
  ERRBADCONST:          ES:='ILLEGAL CONSTANT.';
  ERRBADEXPR:           ES:='ILLEGAL EXPRESSION.';
  ERRARITHOFLO:         ES:='ARITHMETIC OVERFLOW.';
  ERRFIELDOFLO:         ES:='FIELD OVERFLOW.';
  ERRBADSYNTAX:         ES:='ILLEGAL SYNTAX.';
  ERRBADBASE:           ES:='EXPRESSION IS IMPROPER MODE.';
  ERREXTREFS:           ES:='EXTERNAL REFERENCE NOT ALLOWED.';
  ERRMODEDECL:          ES:='IMPROPER USE OF MODE DECLARATION.';
  ERRPHASE:             ES:='PHASE ERROR.';
  ERRINCOPEN:           ES:='FAILED TO OPEN INCLUDED FILE.';
  ERRBADINCLUDE:        ES:='ATTEMPT TO NEST INCLUDED FILES.';
  ERRBADCOM:            ES:='MORE THAN ONE COM STATEMENT.';
  ERRGOTSTART:          ES:='MORE THAN ONE START STATEMENT.';
  ERRDIROVF:            ES:='MODULE DIRECTORY OVERFLOW.';
  ERRCOMMAEXP:          ES:='COMMA EXPECTED.';
  ERRSYMBEXP:           ES:='SYMBOL EXPECTED.';
  ERREOLEXP:            ES:='BLANK OR END OF LINE EXPECTED.';
  ERRREGEXP:            ES:='REGISTER OR REGISTER LIST EXPECTED.';
  ERRAREGEXP:           ES:='ADDRESS REGISTER EXPECTED.';
  ERRCLOSEPEXP:         ES:='RIGHT PARENTHESIS EXPECTED.';
  ERRMODNAME:           ES:='MORE THAN ONE MNAME STATEMENT.';
  errTASwarn:           ES:='TAS MAY NOT BE IMPLEMENTED BY HARDWARE.';
  errlinecnt:           es:='MORE THAN 32767 LINES.';
$if mc68881$
  errfpregnotallowed:   es:='FLOATING POINT REGISTER NOT ALLOWED.';
  errfpsysregnotallowed:es:='FLOATING POINT SYSTEM REGISTER NOT ALLOWED.';
  errfpopdnotallowed:   es:='FLOATING POINT OPERAND NOT ALLOWED.';
  errdifffpregneeded:   es:='DIFFERENT FLOATING POINT REGISTERS NEEDED.';
  errfpconstneeded:     es:='FLOATING POINT CONSTANT NEEDED.';
  errfpregneeded:       es:='FLOATING POINT REGISTER NEEDED.';
  errfpsysregneeded:    es:='FLOATING POINT SYSTEM REGISTER NEEDED.';
  errfpmonadicneeded:   es:='SINGLE OPERAND INVALID ON THIS INSTRUCTION.';
  errfpel:              es:='USE OF "L" EXPONENT FLAG NOT ALLOWED.';
  errfpregexp:          es:='FLOATING POINT REGISTER (OR LIST) EXPECTED.';
  errbadfpk:            es:='INVALID FLOATING POINT BCD "K-FACTOR".';
  errfpromconst:        es:='INVALID FLOATING POINT ROM CONSTANT ADDRESS.';
  errfpimmedparse:      es:='INVALID FLOATING POINT IMMEDIATE OPERAND.';
  errfpimmedsize:       es:='FLOATING POINT IMMEDIATES MUST BE SIZE ".D".';
  errfpbccsize:         es:='32 BIT FBcc DISPLACEMENTS NOT SUPPORTED.';

  errfpinternalerr:     es:='INTERNAL ASSEMBLER ERROR.';

$end$
  ERRCOLONEXP:          ES:='(":") COLON EXPECTED.';
  ERRLBRACEEXP:         ES:='("{") LEFT BRACE EXPECTED.';
  ERRRBRACEEXP:         ES:='("}") RIGHT BRACE EXPECTED.';
  ERRRBRACKEXP:         ES:='("]") RIGHT BRACKET EXPECTED.';
  ERRRBRACKUNEXP:       ES:='("]") RIGHT BRACKET UNEXPECTED.';
  ERR2INNER:            ES:='TOO MANY INNER EXPRESSIONS.';
  ERR2DISP:             ES:='TOO MANY DISPLACEMENTS.';
  ERR2INDEX:            ES:='TOO MANY INDEXES.';
  ERR2AN:               ES:='TOO MANY ADDRESS REGISTERS.';
  ERR2ZPC:              ES:='TOO MANY ZPC''S.';
  ERRMISZPC:            ES:='MISPLACED ZPC.';
  ERRBADSCALE:          ES:='IMPROPER SCALE.';
  ERRRELREFS:           ES:='RELATIVE REFERENCE NOT ALLOWED.';
  END;
IF LISTNAME='CONSOLE:' THEN LISTINST(5);
WRITELN(LP,'  ',ES);
LPCHECK;                   { 3/2/84 }


IF ER <> ERRTASWARN THEN
  BEGIN
    LASTERRLINE:=LINENO;
    ERRCOUNT:=ERRCOUNT+1;
  END;

END;


PROCEDURE ERROR (* ER: ERRORCODE *); {FWD}
VAR
  NUMLEFT: SHORTINT;
  stemp: lstring;

BEGIN
IF (PASS=1) OR (NOT (LISTING AND SUPERLIST)) THEN
  BEGIN
    stemp:=printline;
    if not didheader then
      doheader;
    LISTINST(5);
    WRITE(LP, LINENO:5, ' ');
    LPCHECK;                                            { JWS 3/2/84 }
    NUMLEFT:=LLEN-6;
    if (currop.name='DC       ') and  (printline='') then
       printline:=line;
    IF NUMLEFT>=LENGTH(PRINTLINE) THEN
       WRITELN(LP,PRINTLINE)
    ELSE
      WRITELN(LP,COPY(PRINTLINE,1,NUMLEFT));
    LPCHECK;                                            { JWS 3/2/84 }
    LISTERROR(ER);
    printline:=stemp;
  END
ELSE
  IF NOT ERRINLINE THEN BEGIN
    ERRINLINE:=TRUE;
    LINEERRCODE:=ER;
  END
END;



FUNCTION MEMALT{ (OP:OPERAND): BOOLEAN };   {FWD}
{ DETERMINES IF AN OPERAND IS MEMORY ALTERABLE }
BEGIN
  IF ((OP.MODE>1) AND (OP.MODE<7)) OR
     ((OP.MODE=7) AND (OP.REG<=1))
       THEN MEMALT:=TRUE
       ELSE MEMALT:=FALSE
END;

FUNCTION ALTERABLE{ (OP: OPERAND): BOOLEAN};  { FWD DECLARED }
{ DETERMINES IF AN OPERAND IS IN THE ALTERABLE CLASS }
BEGIN
$if not mc68881$
IF OP.MODE<7 THEN ALTERABLE:=TRUE
ELSE IF OP.REG<2 THEN ALTERABLE:=TRUE
       ELSE ALTERABLE:=FALSE;
$end$
$if mc68881$
if (op.mode < 7) or (op.mode = 8) then alterable := true
else
  if (op.mode = 7) and (op.reg < 2) then alterable := true
  else
    if (op.mode = 9) and (op.reg <= 2) then alterable := true
    else
      alterable := false;
$end$
END;

FUNCTION DATALTERABLE{ (OP: OPERAND): BOOLEAN};  { FWD DECLARED }
{ DETERMINES IF AN OPERAND IS IN THE DATA ALTERABLE CLASS }
BEGIN
IF (OP.MODE<7) AND (OP.MODE<>1) THEN DATALTERABLE:=TRUE
ELSE IF (OP.MODE=7) AND (OP.REG<2) THEN DATALTERABLE:=TRUE
$if mc68881$
else if (op.mode = 8 ) then datalterable := true
$end$
       ELSE DATALTERABLE:=FALSE;
END;

FUNCTION CONTROLALTERABLE{ (OP: OPERAND): BOOLEAN};  { FWD DECLARED }
{ DETERMINES IF AN OPERAND IS IN THE CONTROL AND ALTERABLE CLASSES }
BEGIN
CONTROLALTERABLE:=(OP.MODE=2) OR (OP.MODE=5) OR (OP.MODE=6) OR
		 ((OP.MODE=7) AND (OP.REG<=1));
END;

FUNCTION CONTROLMODE{(OP: OPERAND): BOOLEAN};  { FWD DECLARED}
BEGIN
IF ((OP.MODE<=4) AND (OP.MODE<>2)) OR
   ((OP.MODE=7) AND (OP.REG=4)) THEN
     CONTROLMODE:=FALSE
$if mc68881$
else if ( op.mode = 8 ) then controlmode := false
$end$
ELSE CONTROLMODE:=TRUE;
END;

FUNCTION DATAMODE{(OP:OPERAND): BOOLEAN};  { FWD DECLARED }
BEGIN
IF (OP.MODE<>1) AND NOT((OP.MODE=7)AND (OP.REG>4)) THEN
  DATAMODE:=TRUE
ELSE DATAMODE:=FALSE;
END;


$if mc68881$
function memmode (* ( opd : operand ) : boolean *);     (* fwd declared *)
begin
  if (opd.mode > 1) and (opd.mode < 7) then
    memmode := true
  else
    if (opd.mode = 7) and (opd.reg <= 4) then
      memmode := true
    else
      memmode := false;
end;
$end$


PROCEDURE LISTINST{FHTCODE:SHORTINT};  { FWD DECLARED }
TYPE HDIGITS=PACKED ARRAY[1..16] OF CHAR;

VAR IDX,LINESREQ:SHORTINT;
    C1,C2: CHAR;
    HEX: HDIGITS;
    NUMLEFT: SHORTINT;
    I: SHORTINT;



PROCEDURE ITOHEX(INUM:SHORTINT);
BEGIN
  C1:=HEX[INUM DIV 16 + 1];
  C2:=HEX[INUM MOD 16 + 1];
END;

PROCEDURE NEWPAGE;
VAR I:SHORTINT;
  BEGIN
    PAGENUMBER:=PAGENUMBER+1;
    page(LP);
    LPCHECK;                                      { JWS 3/2/84 }
    FOR I:=1 TO TOPMARGIN DO BEGIN WRITELN(LP); LPCHECK; END;  { 3/2/84 }
    WITH CDATE DO
      {LAF 880101 added "MOD 100"}
      WRITELN(LP,' PAGE',PAGENUMBER:4,' ',VERSTRING,' ',
	MONTH:1,'/',DAY:1,'/',YEAR MOD 100:1,' ',ctimestr,' ',TITLE);
    LPCHECK;                                                   { JWS 3/2/84 }
    WRITELN(LP);
    LPCHECK;                                                   { JWS 3/2/84 }
    CURRENTLINE:=TOPMARGIN+2;
  END;


PROCEDURE LISTPC;
  BEGIN
    if decimal then BEGIN write(lp,locctr.longint:11); LPCHECK; END { 3/2/84}
    else begin
      write(lp,' ':3);
      LPCHECK;                                               { JWS 3/2/84 }
      ITOHEX(LOCCTR.BYTE1);WRITE(LP,C1,C2);
      LPCHECK;                                               { JWS 3/2/84 }
      ITOHEX(LOCCTR.BYTE2);WRITE(LP,C1,C2);
      LPCHECK;                                               { JWS 3/2/84 }
      ITOHEX(LOCCTR.BYTE3);WRITE(LP,C1,C2);
      LPCHECK;                                               { JWS 3/2/84 }
      ITOHEX(LOCCTR.BYTE4);WRITE(LP,C1,C2);
      LPCHECK;                                               { JWS 3/2/84 }
    end;
    WRITE(LP,' ');
    LPCHECK;                                               { JWS 3/2/84 }
  END;


PROCEDURE LISTCODE(IDX:SHORTINT);
  BEGIN
    IF IDX>CODELENGTH THEN WRITE(LP,'  ')
       ELSE BEGIN                                          { JWS 3/20/84 }
	 ITOHEX(CODE.BYT[IDX]);WRITE(LP,C1,C2); END;       { JWS 3/20/84 }
    LPCHECK;                                               { JWS 3/2/84 }
  END;

(* LIST INSTRUCTION AND SOURCE LINE *)
BEGIN
  HEX:='0123456789ABCDEF';
  IF (SUPERLIST AND LISTING) OR (FHTCODE=5)  THEN
    BEGIN
$if mc68881$
  if fhtcode > 2 then
    linesreq := 1
  else
    linesreq := 1 + ord( codelength > 4 ) + ord( codelength > 8 )
		+ ord( codelength > 12 );
$end$
$if not mc68881$
  IF FHTCODE>2 THEN LINESREQ:=1 ELSE LINESREQ:=1+ORD(CODELENGTH>4);
$end$
  IF (LINESREQ+CURRENTLINE)>(LINESPERPAGE-BOTMARGIN) THEN NEWPAGE;
  CURRENTLINE:=CURRENTLINE+LINESREQ;
  IF FHTCODE<5 THEN
    BEGIN
      WRITE(LP,LINENO:5); LPCHECK; WRITE(LP,' ');       { JWS 3/2/84 }
      LPCHECK;                                          { JWS 3/2/84 }
      CASE FHTCODE OF
      1: (* NORMAL LINE *) BEGIN LISTPC;LISTCODE(1);LISTCODE(2);
	 WRITE(LP,' '); LPCHECK; LISTCODE(3); LISTCODE(4); END;  { JWS 3/2/84 }
      2: (* NO PC *) BEGIN WRITE(LP,' ':12); LPCHECK;            { JWS 3/2/84 }
	 LISTCODE(1);LISTCODE(2);
	 WRITE(LP,' '); LPCHECK; LISTCODE(3); LISTCODE(4) END;   { JWS 3/2/84 }
      3: (* NO CODE *) BEGIN LISTPC;WRITE(LP,' ':9);LPCHECK; END; { JWS 3/2/84 }
      4: (* NO PC OR CODE *) BEGIN WRITE(LP,' ':21);LPCHECK;END;  { JWS 3/2/84 }
      END;
      NUMLEFT:=LLEN-28;
      IF NUMLEFT>=LENGTH(PRINTLINE) THEN
	WRITELN(LP,' ',PRINTLINE)
      ELSE
	WRITELN(LP,' ',COPY(PRINTLINE,1,NUMLEFT));
      LPCHECK;                                                 { JWS 3/2/84 }
      IF FHTCODE<3 THEN
	IF CODELENGTH>4 THEN
	  BEGIN
	    IDX:=5;
	    WRITE(LP,' ':18);
	    LPCHECK;                                            { JWS 3/2/84 }
	    REPEAT
	      BEGIN
	      LISTCODE(IDX);LISTCODE(IDX+1);WRITE(LP,' ');
	      LPCHECK;                                          { JWS 3/2/84 }
	    IDX:=IDX+2;
	      END;
	    UNTIL IDX>CODELENGTH;
	    WRITELN(LP);
	    LPCHECK;                                            { JWS 3/2/84 }
	  END;
    END;
  END;
END;

PROCEDURE INTERPASS{WHICH: SHORTINT};
  var
    i: integer;
    seconds: shortint;

  PROCEDURE INITLIBDIR;   { INITIALIZE LIBRARY DIRECTORY }
   VAR I: SHORTINT;
  BEGIN
  FOR I:=0 TO 511 DO PUNCHBLK[I]:=0;
  LDIRP:=LDIRPTRTYPE(ADDR(PUNCHBLK));
  WITH LDIRP^[0] DO BEGIN
    DFIRSTBLK:=0;
    DLASTBLK:=1;
    DFKIND:=UNTYPEDFILE;
    DVID:='LIB';
    DEOVBLK:=1;
    DNUMFILES:=1;
    DLOADTIME:=0;
    DLASTBOOT:=CDATE;
  END;
  WITH LDIRP^[1] DO BEGIN
    DFIRSTBLK:=1;
    DLASTBLK:=0;   { TO FILL IN LATER }
    DFKIND:=CODEFILE;
    DTID:=MODNAME;
    DLASTBYTE:=1;
    DACCESS:=CDATE;
  END;
  if object then begin
    I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1,0);
    IF I<>1 THEN ERROR(errwrite);
  end;
  END;  { OF PROCEDURE }

  PROCEDURE INITIALIZEMD;
    VAR I: SHORTINT;
  BEGIN
  FOR I:=0 TO 511 DO PUNCHBLK[I]:=0;
  MDPTR:=MDPTRTYPE(ADDR(PUNCHBLK));
  WITH MDPTR^ DO BEGIN
    DATE:=CDATE;
    REVISION:=RDATE;
    PRODUCER:='A';
    SYSTEMID:=ord(verstring[2]) - ord('0');
    NOTICE:='';
  END;
  TEXTINFO:=SIZEOF(MODULEDIRECTORY);   { INITIAL BYTE OFFSET FOR THIS }
  if object then begin
    I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1,1);
    IF I<>1 THEN ERROR(errwrite);
  end;
  END;

  PROCEDURE INSERTMODNAME;
  VAR I: INTEGER;
  BEGIN
  PUNCHLC:=TEXTINFO;
  if object then begin
    I:=BLOCKREAD(OBJFILE,PUNCHBLK,1,1);
    IF I<>1 THEN ERROR(errcread);
  end;
  FOR I:=0 TO LENGTH(MODNAME) DO
    PUNCHBYTE(ORD(MODNAME[I]));
  IF ODD(PUNCHLC) THEN PUNCHLC:=PUNCHLC+1;
  TEXTINFO:=PUNCHLC;
  if object then begin
    I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1,1);
    IF I<>1 THEN ERROR(errwrite);
  end;
  END;

  PROCEDURE DOCLEANUP;  { FILL IN DIRECTORY HOLES}
  VAR LENGTH: INTEGER;
      OVID: VID;
      OTID: TID;
      I: INTEGER;
      KIND: FILEKIND;


  BEGIN
  IF CONTIGUOUS THEN
    TEXTSIZE:=LOCCTR.LONGINT-ORIGIN
  ELSE
     TEXTSIZE:=ENDOFCODE-ORIGIN;
  if object then begin
    I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1, OBJCTR); { OUTPUT LAST BLOCK}
    IF I<>1 THEN listerror(errwrite);
    I:=BLOCKREAD(OBJFILE,PUNCHBLK,1,1); { GET MODULE DIR. BLOCK}
    IF I<>1 THEN listerror(errcread);
  end;
  PUNCHLC:=TEXTINFO;
  IF PUNCHLC+22>511 THEN listerror(ERRDIROVF);
  PUNCHDWORD(TEXTSTART);
  PUNCHDWORD(TEXTSIZE);
  PUNCHDWORD(REFSTART);
  PUNCHDWORD(REFSIZE);
  IF PCMODE=REL THEN GV.PRIMARYTYPE:=RELOCATABLE
    ELSE GV.PRIMARYTYPE:=ABSOLUTE;
  GV.DATASIZE:=SINT;
  GV.PATCHABLE:=FALSE;
  GV.VALUEEXTEND:=TRUE;
  GV.LONGOFFSET:=FALSE;
  GV.SHORT:=6;
  PUNCHGVR(GV);
  PUNCHDWORD(ORIGIN);
  MDPTR:=MDPTRTYPE(ADDR(PUNCHBLK));
  MDPTR^.MODULESIZE:=OBJCTR*512;
  if pcmode=rel then
    if locctr.longint > highaddr.longint then highaddr:=locctr;
  MDPTR^.RELOCATABLESIZE:=highaddr.longint-lowrorg.longint;
  MDPTR^.RELOCATABLEBASE:=LOWRORG.LONGINT;
  MDPTR^.GLOBALSIZE:=GLOBALSIZE;
  MDPTR^.GLOBALBASE:=GLOBALBASE;
  MDPTR^.DIRECTORYSIZE:=PUNCHLC;
  MDPTR^.TEXTRECORDS:=TEXTRECORDS+1;
  MDPTR^.EXTBLOCK:=EXTSTART;
  MDPTR^.EXTSIZE:=EXTSIZE;
  MDPTR^.DEFBLOCK:=DEFSTART;
  MDPTR^.DEFSIZE:=DEFSIZE;
  MDPTR^.SOURCEBLOCK:=SOURCESTART;
  MDPTR^.SOURCESIZE:=SOURCESIZE;
  if object then begin
    I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1,1);
    IF I<>1  THEN listerror(errwrite);
    I:=BLOCKREAD(OBJFILE, PUNCHBLK,1,0);
    IF I<>1 THEN listerror(errcread);
  end;
  LDIRP:=LDIRPTRTYPE(ADDR(PUNCHBLK));
  LDIRP^[1].DLASTBLK:=OBJCTR+1;
  if object then begin
    I:=BLOCKWRITE(OBJFILE, PUNCHBLK, 1, 0);
    IF I<>1 THEN listerror(errwrite);
    CLOSE(OBJFILE,'LOCK');
    IF IORESULT<>0 THEN listerror(errwrite);
  end
  else close(objfile,'PURGE');
  IF (PASS1ERRS=0) AND (ERRCOUNT=0) THEN BEGIN
   USERINFO^.GOTCODE:=TRUE;
   USERINFO^.CODEFID:=OBJNAME;
  END;
  END;


  PROCEDURE INITFILES;
  LABEL 1,2;
  VAR I,J: SHORTINT;
      defaultlistfile,
      DEFAULTFILENAME: STRING80;

    function getfid(s: fid): fid;
      begin
      if suffix(s) <> datafile then
	begin
	i := strlen(s);
	while s[i] <> '.' do
	  i := i - 1;
	getfid := str(s,1,i-1);
	end
      else
	getfid := s;
      end;

    BEGIN
      SUPERLIST:=FALSE;
      DOREAD;      { INITIALIZE SOURCE INPUT }
      IF USERINFO^.GOTSYM THEN BEGIN
	LAB:='CONSOLE:';
	REWRITE(LP,LAB);
      END
      ELSE BEGIN
1:      LAB:='';
	SUPERLIST:=FALSE;
	REPEAT
	  WRITE('Do you want a program listing (y/n/e) ? ');
	  READ(REPLY);
	  WRITELN;
	  IF STREAMING AND NOT(REPLY IN ['y','Y','e','E','n','N'])
	    THEN BEGIN
	      WRITELN('Bad response to "program listing" query!');
	      ESCAPE(-1);
	  END;
	UNTIL REPLY IN ['Y','y','N','n','E','e'];
	IF (REPLY='Y') OR (REPLY='y') THEN SUPERLIST:=TRUE;
	IF (REPLY='N') OR (REPLY='n') THEN begin
	   superlist:=false;
	  LAB:='CONSOLE:'
	end
	ELSE BEGIN
	  defaultlistfile := 'PRINTER:' +
	    getfid(fibp(addr(filevar))^.ftid) + '.ASC';
	  WRITE('What listing file (default ',defaultlistfile,') ? ');
	  READLN(LAB);
	  fixname(lab,textfile);
	  IF LAB='' THEN LAB:=defaultlistfile;
	END;
	REWRITE(LP,LAB);
	IF IORESULT<>0 THEN BEGIN
	  I:=IORESULT;
	  getioerrmsg(iomsg, i);
	  writeln('Error: ',iomsg);
	  IF STREAMING THEN ESCAPE(-1) ELSE GOTO 1;
	END;
      END;
      LISTNAME:=LAB;
      defaultfilename := getfid(sourcefilename) + '.CODE';
      IF USERINFO^.GOTSYM THEN
	OBJNAME:=DEFAULTFILENAME
      ELSE BEGIN
2:      WRITE('Output file (default is ',DEFAULTFILENAME,') ? ');
	READLN(OBJNAME);
	fixname(objname,codefile);
	IF OBJNAME='' THEN
	  OBJNAME:=DEFAULTFILENAME;
      END;
      REWRITE(OBJFILE, OBJNAME);
      I:=IORESULT;
      IF I<>0 THEN BEGIN
	getioerrmsg(iomsg,i);
	writeln('Error: ',iomsg);
	IF STREAMING THEN ESCAPE(-1) else goto 2;
      END;
      MODNAME:=getfid(fibp(addr(filevar))^.ftid);
      if strlen(modname) > 15 then
	setstrlen(modname,15);
    END;

  PROCEDURE INITABLES;
    VAR CH:CHAR;
    BEGIN
      ZERO32.HIHALF:=0; ZERO32.LOHALF:=0;
      FOR CH:=CHR(0) TO CHR(255) DO
	BEGIN XLATE[CH]:=CH; CHTYPE[CH]:=SPECIAL END;
      FOR CH:='A' TO 'Z' DO CHTYPE[CH]:=ALPHABETIC;
      FOR CH:='a' TO 'z' DO
	BEGIN
	  CHTYPE[CH]:=ALPHABETIC;
	  XLATE[CH]:=CHR(ORD(CH)-ORD('a')+ORD('A'))
	END;
      CHTYPE['_']:=ALPHABETIC; CHTYPE['@@']:=ALPHABETIC;
      CHTYPE['$']:=ALPHABETIC; { CHTYPE[':']:=ALPHABETIC;  NO!  NO!  NO! }
      FOR CH:='0' TO '9' DO CHTYPE[CH]:=NUMERIC;
      DOSYMS;  {INITIALIZE SYMBOL TABLE HASH}

      LAB:='D0'; STDSYM(0,DREG);
      LAB:='D1'; STDSYM(1,DREG);
      LAB:='D2'; STDSYM(2,DREG);
      LAB:='D3'; STDSYM(3,DREG);
      LAB:='D4'; STDSYM(4,DREG);
      LAB:='D5'; STDSYM(5,DREG);
      LAB:='D6'; STDSYM(6,DREG);
      LAB:='D7'; STDSYM(7,DREG);

      LAB:='A0'; STDSYM(0,AREG);
      LAB:='A1'; STDSYM(1,AREG);
      LAB:='A2'; STDSYM(2,AREG);
      LAB:='A3'; STDSYM(3,AREG);
      LAB:='A4'; STDSYM(4,AREG);
      LAB:='A5'; STDSYM(5,AREG);
      LAB:='A6'; STDSYM(6,AREG);
      LAB:='A7'; STDSYM(7,AREG);
      LAB:='SP'; STDSYM(7,AREG);

      LAB:='CCR';  STDSYM( 5,STREG);
      LAB:='SR';   STDSYM( 6,STREG);
      LAB:='USP';  STDSYM( 7,STREG);
      LAB:='DFC';  STDSYM( 8,STREG);
      LAB:='SFC';  STDSYM( 9,STREG);
      LAB:='VBR';  STDSYM(10,STREG);
      LAB:='MSP';  STDSYM(11,STREG);
      LAB:='ISP';  STDSYM(12,STREG);
      LAB:='CACR'; STDSYM(13,STREG);
      LAB:='CAAR'; STDSYM(14,STREG);
{ Added for the new '040 registers JWH 12/26/89 : }
      LAB:='TC'; STDSYM(15,STREG);
      LAB:='ITT0'; STDSYM(16,STREG);
      LAB:='ITT1'; STDSYM(17,STREG);
      LAB:='DTT0'; STDSYM(18,STREG);
      LAB:='DTT1'; STDSYM(19,STREG);
      LAB:='MMUSR'; STDSYM(20,STREG);
      LAB:='URP'; STDSYM(21,STREG);
      LAB:='SRP'; STDSYM(22,STREG);
$if mc68881$
      lab := 'FP0'; stdsym( 0, fpreg );
      lab := 'FP1'; stdsym( 1, fpreg );
      lab := 'FP2'; stdsym( 2, fpreg );
      lab := 'FP3'; stdsym( 3, fpreg );
      lab := 'FP4'; stdsym( 4, fpreg );
      lab := 'FP5'; stdsym( 5, fpreg );
      lab := 'FP6'; stdsym( 6, fpreg );
      lab := 'FP7'; stdsym( 7, fpreg );
      lab := 'FPCONTROL'; stdsym( 0, fpstreg );
      lab := 'FPSTATUS';  stdsym( 1, fpstreg );
      lab := 'FPIADDR';   stdsym( 2, fpstreg );
$end$
      LAB:='ZPC';  STDSYM(16,PREG);
    END;

  PROCEDURE INSERTSTART;
  VAR I: SHORTINT;
  BEGIN
    if object then begin
      I:=BLOCKREAD(OBJFILE, PUNCHBLK, 1,1);
      IF I<>1 THEN ERROR(errcread);
    end;
    PUNCHLC:=TEXTINFO;
    MDPTR:=MDPTRTYPE(ADDR(PUNCHBLK));
    MDPTR^.EXECUTABLE:=TRUE;
    GV.PRIMARYTYPE:=STARTMODE;
    GV.DATASIZE:=SINT;
    GV.PATCHABLE:=FALSE;
    GV.VALUEEXTEND:=TRUE;
    GV.LONGOFFSET:=FALSE;
    GV.SHORT:=6;
    PUNCHGVR(GV);
    PUNCHDWORD(STARTLOC.LONGINT);
    TEXTINFO:=PUNCHLC;
    if object then begin
      I:=BLOCKWRITE(OBJFILE,PUNCHBLK,1,1);
      IF I<>1 THEN ERROR(errwrite);
    end;
    END;

  PROCEDURE COPYSOURCE;

  VAR TEMPSOURCE: SOURCEPTR;
      I: SHORTINT;
      N: SHORTINT;  { USED TO COUNT PAGES }


  BEGIN
    IF SOURCEHEAD<>NIL THEN BEGIN
      IF (PUNCHLC<>0) THEN ENDBLOCK;
      SOURCESTART:=OBJCTR-1;
      SOURCESIZE:=0;
      N:=0;
      TEMPSOURCE:=SOURCEHEAD;
      WHILE TEMPSOURCE<>NIL DO BEGIN
	IF (LENGTH(TEMPSOURCE^.SOURCELINE) + PUNCHLC+ORD(ODD(N))) > 511 THEN
	  IF ODD(N) THEN BEGIN   { NEW PAGE }
	    FOR I:=PUNCHLC TO 511 DO PUNCHBLK[I]:=0;
	    if object then begin
	      I:=BLOCKWRITE(OBJFILE, PUNCHBLK, 1, OBJCTR);
	      IF I<>1 THEN listerror(errwrite);
	    end;
	    OBJCTR:=OBJCTR+1;
	    N:=N+1;
	    PUNCHLC:=0;
	  END
	  ELSE N:=N+1;
	FOR I:=1 TO LENGTH(TEMPSOURCE^.SOURCELINE) DO
	  PUNCHBYTE(ORD(TEMPSOURCE^.SOURCELINE[I]));
	PUNCHBYTE(13);  { PUT OUT A CR }
	TEMPSOURCE:=TEMPSOURCE^.NEXTSOURCE;
      END;
      IF ODD(N) THEN BEGIN
	PUNCHBLK[PUNCHLC]:=3;
	FOR I:=(PUNCHLC+1) TO 511 DO PUNCHBLK[I]:=0;
	SOURCESIZE:=(N+1)*512;
	PUNCHLC:=511;
      END
      ELSE IF PUNCHLC>0 THEN BEGIN
	PUNCHBLK[PUNCHLC]:=3;
	FOR I:=(PUNCHLC+1) TO 511 DO PUNCHBLK[I]:=0;
	if object then begin
	  I:=BLOCKWRITE(OBJFILE, PUNCHBLK, 1, OBJCTR);
	  IF I<>1 THEN listerror(errwrite);
	end;
	OBJCTR:=OBJCTR+1;
	PUNCHLC:=511;
	FOR I:=0 TO 511 DO PUNCHBLK[I]:=0;
	SOURCESIZE:=(N+2)*512
      END
    END
  END;

  BEGIN { BODY OF INTERPASS }
    CASE WHICH OF
      1: BEGIN
	   PASS:=1;
	   didheader:=false;
	   listdone:=false;
	   decimal:=false;
	   OBJECT:=TRUE;
	   GOTSTART:=FALSE;
	   GOTMODNAME:=FALSE;
	   GOTCOM:=FALSE;
	   MODNAME:='';
	   RDATE.MONTH:=MONTH;
	   RDATE.DAY:=DAY;
	   RDATE.YEAR:=YEAR;
	   systime(ctime);
	   setstrlen(ctimestr,0);
	   i := 1;
	   if ctime.hour < 10 then
	     strwrite(ctimestr,i,i,'0');
	   strwrite(ctimestr,i,i,ctime.hour:1,':');
	   if ctime.minute < 10 then
	     strwrite(ctimestr,i,i,'0');
	   strwrite(ctimestr,i,i,ctime.minute:1,':');
	   seconds := ctime.centisecond div 100;
	   if seconds < 10 then
	     strwrite(ctimestr,i,i,'0');
	   strwrite(ctimestr,i,i,seconds:1);
	   SYSDATE(CDATE);
	   with cdate do
	   {LAF 880101 added "mod 100"'s}
	   writeln('Assembler [ Rev ',copy(verstring,
		   2,strlen(verstring)-2),' ',rdate.month:1,'/',rdate.day:1,'/',
		   rdate.year mod 100:1,' ] ',
		   month:1,'/',day:1,'/',year mod 100:1,' ',ctimestr);
	   writeln;
	   writeln('Copyright Hewlett-Packard Company, 1982, 1991.');
	   writeln('           All rights reserved.');
	   writeln;
	   EXTHEAD:=NIL; EXTTAIL:=NIL;
	   DEFHEAD:=NIL; DEFTAIL:=NIL;
	   REFHEAD:=NIL; REFTAIL:=NIL;
	   SOURCEHEAD:=NIL; SOURCETAIL:=NIL;
	   OPERAND1.VALUE.EXPREFS:=NIL;
	   OPERAND2.VALUE.EXPREFS:=NIL;
	   OPERAND3.VALUE.EXPREFS:=NIL;
	   OPERAND4.VALUE.EXPREFS:=NIL;
	   OPERAND5.VALUE.EXPREFS:=NIL;
	   OPERAND6.VALUE.EXPREFS:=NIL;
	   LASTERRLINE:=0;
	   LISTING:=TRUE;
	   PAGENUMBER:=1;
	   TOPMARGIN:=1;
	   BOTMARGIN:=6;
	   CURRENTLINE:=2;
	   LINESPERPAGE:=66;
	   LLEN:=132;
	   ERRCOUNT:=0;
	   INITFILES;
	   INITABLES;
	   TITLE:=CONCAT(' ASSEMBLY OF ',fibp(addr(filevar))^.ftid);
	   GLOBALSIZE:=0;
	   GLOBALBASE:=0;
	   EXTCTR:=0;
	   EXTSIZE:=8;
	   DEFCTR:=0;
	   REFCTR:=0;
	   SOURCESTART:=0;
	   SOURCESIZE:=0;
	   LOCCTR:=ZERO32;
	   PCMODE:=REL;
	   ORGMODE:=SHORTFWDS;
	   LISTSYMS:=TRUE;
	   if superlist then
	     doheader;
	 END;

      2: BEGIN
	 llen:=132;
	 CONTIGUOUS:=TRUE;
	 INITLIBDIR;
	 INITIALIZEMD;
	 INSERTMODNAME;
	 IF GOTSTART THEN INSERTSTART;
	 OBJCTR:=2;
	 TEXTSTART:=1;
	 TEXTRECORDS:=0;
	 FIRSTREF:=TRUE;
	 PUNCHLC:=0;
	 if didheader and  (listname<>'CONSOLE:') then BEGIN  { 3/2/84 }
	      WRITELN(LP,'PASS 1 COMPLETE. ERRORS: ', ERRCOUNT:1);
	      LPCHECK;                                        { 3/2/84 }
	 END;                                                 { 3/2/84 }
	 if listname<>'CONSOLE:' then BEGIN                   { 3/2/84 }
	      writeln('PASS 1 COMPLETE. ERRORS: ', errcount:1);
	      LPCHECK;                                        { 3/2/84 }
	  END;                                                { 3/2/84 }
	 PASS1ERRS:=ERRCOUNT;
	 PASS:=2;
	 SHORTMODE:=FALSE;
	 LASTERRLINE:=0;
	 ERRINLINE:=FALSE;
	 ERRCOUNT:=0;
	 ORIGIN:=0;
	 LOCCTR:=ZERO32;
	 HIGHADDR:=ZERO32;
	 LOWRORG.LOHALF:=-1;
	 LOWRORG.HIHALF:=-1;
	 PCMODE:=REL;
	 ORGMODE:=SHORTFWDS;
	 TRY OPENINPUT  {RE-OPEN THE SOURCE FILE}
	   RECOVER ESCAPE(-1);
	 END;

      3: BEGIN
	 listdone:=true;
	 IF (LOWRORG.LOHALF=-1) AND (LOWRORG.HIHALF=-1) THEN LOWRORG:=ZERO32;
	 REFCOPY;
	 COPYLINKS;
	 COPYSOURCE;
	 DOCLEANUP;
	 if didheader or (listname='CONSOLE:') then begin
	   LISTINST(5);
	   WRITELN(LP,'PASS 1 ERRORS: ', PASS1ERRS:1);
	   LPCHECK;                                          { JWS 3/2/84 }
	   LISTINST(5);
	   LPCHECK;                                          { JWS 3/2/84 }
	   WRITE(LP,'PASS 2 ERRORS: ',ERRCOUNT:1);
	   LPCHECK;                                          { JWS 3/2/84 }
	 end;
	 IF LISTNAME<>'CONSOLE:' THEN
	   WRITELN('PASS 2 COMPLETE. ERRORS: ',ERRCOUNT:1);
	 IF ERRCOUNT<>0 THEN BEGIN
	   WRITELN(LP,'  SEE LINE: ',LASTERRLINE:1);
	   LPCHECK;                                          { 3/2/84 }
	 END                                                 { 3/2/84 }
	   else if didheader then BEGIN writeln(lp); LPCHECK; END; { 3/2/84 }
	 IF SUPERLIST AND LISTSYMS THEN BEGIN
	   CURRENTLINE:=70;
	   LISTINST(5);
	   DUMPTABLE;
	 END
       END;
    END
  END;   { INTERPASS }

 { UTILITY MODULE } END;



@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@@


53.2
log
@Updated copyright message.
@
text
@@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@d795 1
a795 1
	   writeln('Copyright Hewlett-Packard Company, 1982, 1990.');
@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.2
log
@Updated copyright message.
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@d795 1
a795 1
	   writeln('Copyright Hewlett-Packard Company, 1982, 1987.');
@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.2
log
@

          Added code to enter the new '040 registers supported 
      by the movec instruction as standard symbols. JWH 12/26/89.
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@d656 9
@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.3
log
@
Comment from auto synch of clock fix:
date: 88/03/02 17:18:04;  author: quist;  state: Exp;  lines added/del: 7/3
SYSDATE fixes, RDQ
@
text
@@


26.2
log
@
Comment from auto synch of clock fix:
date: 88/03/02 08:59:34;  author: bayes;  state: Exp;  lines added/del: 0/0
Automatic bump of revision number for PWS version 3.2Y
@
text
@d37 1
d39 1
a39 1
	    MONTH:1,'/',DAY:1,'/',YEAR:1,' ',ctimestr,' ',TITLE);
d290 1
d292 1
a292 1
	MONTH:1,'/',DAY:1,'/',YEAR:1,' ',ctimestr,' ',TITLE);
d780 1
d783 2
a784 1
		   rdate.year:1,' ] ',month:1,'/',day:1,'/',year:1,' ',ctimestr);
@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.3
log
@Pws2unix automatic delta on Tue Aug 25 18:23:33 MDT 1987
@
text
@@


22.2
log
@changed errTASwarn message to "MAY NOT BE", because some hardware
now supports TAS
@
text
@d782 2
a783 2
	   writeln('':5,'Copyright 1985 Hewlett-Packard Company.');
	   writeln('':14,'All rights reserved.');
@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@d101 1
a101 1
  errTASwarn:           ES:='TAS NOT IMPLEMENTED BY HARDWARE.';
@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@@


7.2
log
@Fixes for SSS
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@d133 1
d893 1
@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@@


1.1
log
@Initial revision
@
text
@@
