$title('===> N P E X    (I N C L U D E   M A K E R)  <===')

npex: DO;

/************************************************************************/
/*																		*/
/*     'Copyright 1981,1983 Intel Corporation'.  All rights reserved.	*/
/*      No part of this program or publication may be reproduced,		*/
/*      transmitted, transcribed, stored in a retrievel system, or		*/
/*      translated into any language or computer language, in any		*/
/*      form or by any means, electronic, mechanical, magnetic,			*/
/*      optical, chemical, manual or otherwise, without the prior		*/
/*      written permission of Intel Corporation, 3065 Bowers			*/
/*      Avenue, Santa Clara, California, 95051, Attn: Software			*/
/*      License Administration.											*/
/*																		*/
/************************************************************************/

$IF XVERSION
DECLARE PROPRIETARY(*) BYTE DATA ('INTEL PROPRIETARY SOFTWARE');
DECLARE PROGRAM$VERSION$NUMBER$STRING (*) BYTE DATA
    ('program_version_number=X108',0);
$ELSE
DECLARE COPYRIGHT (*) BYTE DATA  ('COPYRIGHT 1981,1983 INTEL ');
DECLARE PROGRAM$VERSION$NUMBER$STRING (*) BYTE DATA
    ('program_version_number=V1.1',0);
$ENDIF


  /****
   *
   *  PEX:
   *    program to create declarations for external routines and variables.
   *    has been extended to PLM86 in addition to accepting input for PLM80.
   *
   *    The added characters are:
   *         'A'  --  ADDRESS.
   *         'B'  --  BYTE.
   *         'I'  --  INTEGER.
   *         'W'  --  WORD.
   *         'R'  --  REAL.
   *         '@'  --  ADDRESS.
   *         'L'  --  LABEL.
   *         '"'  --  "other types"
   *
   *    The syntax for lines in the input file is as follows:
   *
   *       line      =  plm-var (proc-decl | var-decl).
   *       proc-decl = 'P'&param-list&type.
   *       var-decl  =  (type | '"' plm-var '"') [&'S'] [&'..'&plm-var].
   *       params    = (list-12 | '(' &(type | list-12) ... ')'.
   *       list-12   = '1' | '2'.
   *       type      = 'A' | 'B' | 'I' | 'W' | 'R' | '@' | 'L' | '"text"'.
   *
   *    To use, invoke this program as 
   *
   *      :Fx:NPEX <px-file-list> TO <src-file>
   *
   *    where
   *      <px-file-list> ::= <px-file> , ... .
   *      <src-file>     ::= { ISIS-II file name } .
   *      <px-file>      ::= { ISIS-II file name } .
   *
   ****/


declare NIL literally '0';
declare BOOLEAN literally 'byte';
declare CR literally '0DH';
declare LF literally '0AH';
declare FOREVER literally 'while (1)';
declare ENDDO literally 'end';
declare CHAR literally 'byte';
declare TRUE literally '0FFH';
declare FALSE literally '000H';
declare SCANP address external;
declare SCANBYTE BASED SCANP CHAR;
declare SCANADDR BASED SCANP address;
declare OBUFP address external;
declare SCANENDED BOOLEAN external;
BLNKCH:procedure BOOLEAN external;end;
BUMPSCANP:procedure external;end;
CONSOLEIN:procedure external;end;
DDIGCH:procedure byte external;end;
DECIN:procedure address external;end;
ERRORMESSAGE:procedure(ZZ1) external;declare ZZ1 address;end;
FILECH:procedure BOOLEAN external;end;
FILL:procedure(ZZ1,ZZ2,ZZ3) external;declare ZZ1 address,ZZ2 address,ZZ3 byte;end;
FMOVE:procedure(ZZ1,ZZ2,ZZ3) external;declare ZZ1 address,ZZ2 address,ZZ3 address;end;
FORCUP:procedure CHAR external;end;
FORCUPSTRING:procedure external;end;
LENSTRNUL:procedure(ZZ1) byte external;declare ZZ1 address;end;
LETRCH:procedure BOOLEAN external;end;
LTNMCH: procedure byte external; end;
OUTBLANK:procedure external;end;
OUTCHAR:procedure(ZZ1) external;declare ZZ1 CHAR;end;
OUTDEC:procedure(ZZ1) external;declare ZZ1 address;end;
OUTPRINT:procedure(ZZ1) external;declare ZZ1 address;end;
OUTSCANBYTE:procedure external;end;
OUTWRITE:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 byte;end;
PRINT:procedure(ZZ1) external;declare ZZ1 address;end;
PRINTCR:procedure(ZZ1) external;declare ZZ1 address;end;
PUTBLANK:procedure external;end;
PUTCRLF:procedure external;end;
SCANEXPECT:procedure(ZZ1) external;declare ZZ1 address;end;
SCANMATCH:procedure(ZZ1) BOOLEAN external;declare ZZ1 address;end;
SCANUNTIL:procedure(ZZ1) external;declare ZZ1 address;end;
SCANWHILE:procedure(ZZ1) external;declare ZZ1 address;end;
SCANWHILEBLANKS:procedure external;end;
SETOB:procedure(ZZ1) external;declare ZZ1 address;end;
SETSC:procedure(ZZ1) external;declare ZZ1 address;end;
SETSCANENDED:procedure external;end;
TERMCH:procedure BOOLEAN external;end;
TOKNCH:procedure BOOLEAN external;end;
declare STATUS byte external;
declare REPORT BOOLEAN external;
declare FATAL BOOLEAN external;
declare ACTUAL address external;
CLOSEI:procedure external;end;
DEL:procedure(ZZ1) external;declare ZZ1 address;end;
EX:procedure external;end;
ISIS:procedure(ZZ1,ZZ2) external;declare ZZ1 byte,ZZ2 address;end;
MEMCK:procedure address external;end;
OPENI:procedure(ZZ1) external;declare ZZ1 address;end;
OPENO:procedure(ZZ1) external;declare ZZ1 address;end;
READI:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end;
WRITEC:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end;
WRITEO:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end;
EXTRACTROOT: procedure(ZZ1) external; declare (ZZ1) address; end;
FILEERRORMESSAGE:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end;
MOVEFILENAME:procedure(ZZ1) external;declare ZZ1 address;end;
NEWEXTENSION:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end;
OPENSCAN:procedure(ZZ1) external;declare ZZ1 address;end;
OUTFILENAME:procedure(ZZ1) external;declare ZZ1 address;end;
READIWITHLIMIT:procedure(ZZ1,ZZ2) external;declare ZZ1 address,ZZ2 address;end;
$eject

  DECLARE available            ADDRESS,    /* address of memory available for symbols */
          mem$top              ADDRESS,    /* last address usable */
          thread$head          ADDRESS,
          thread$end           ADDRESS,
          file$name$buffer(15) CHAR;

  DECLARE SYMBOL$TABLE$ENTRY LITERALLY
      'STRUCTURE(NEXT   ADDRESS,
                 MARK   BYTE,
                 THREAD ADDRESS,
                 STR(1) CHAR)',

          SYMBOL$TABLE$SIZE       LITERALLY '256',
          SYMBOL$TABLE$ENTRY$SIZE LITERALLY '5',
          SYMBOL$MAX              LITERALLY '40',
          MARKED                  LITERALLY '0FFH',
          UNMARKED                LITERALLY '0',

          symbol$length ADDRESS,
          hash$value    ADDRESS,

          symbol$table(SYMBOL$TABLE$SIZE) ADDRESS,
          symbol$buffer(256)              CHAR;


  DECLARE NULL$STRING                CHAR DATA(0),
          EXTERNAL$STRING(*)         CHAR DATA(' external',0),
          ADDRESS$VARIABLE$STRING(*) CHAR DATA(' address',0),
          BYTE$VARIABLE$STRING(*)    CHAR DATA(' byte',0),
          POINTER$VARIABLE$STRING(*) CHAR DATA(' pointer',0),
          REAL$VARIABLE$STRING(*)    CHAR DATA(' real',0),
          WORD$VARIABLE$STRING(*)    CHAR DATA(' word',0),
          INTEGER$VARIABLE$STRING(*) CHAR DATA(' integer',0),
          LABEL$STRING(*)            CHAR DATA(' label',0),
          DWORD$VARIABLE$STRING(*)   CHAR DATA(' dword',0),
          SELECTOR$VARIABLE$STRING(*)CHAR DATA(' selector',0);

  DECLARE put$symbol$flag BOOLEAN,
          src$file(15)    CHAR INITIAL (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
          src$root(15)    CHAR INITIAL (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
          ipx$file(15)    CHAR INITIAL (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
          px$file$list$p  ADDRESS INITIAL(.io$buff),
          include$count   ADDRESS INITIAL (0),
          include$begin   ADDRESS,
          io$buff(1024)   CHAR,
          io$buff$idx     ADDRESS INITIAL(0);
  DECLARE chars$on$line   BYTE,
          left$margin     BYTE INITIAL(1);
  DECLARE spath             LITERALLY '14',
          spath$buf(12)     BYTE,
          spath$parm$blk(3) ADDRESS INITIAL(.src$file,.spath$buf,.status),
          numeric$extension BYTE;

  DECLARE state  BYTE INITIAL(1),                /* first line cmd line */
          fsm(6) STRUCTURE(NEXT(6) BYTE) DATA(   /* used to scan files  */
          /* ? lf  $  /  *  A */
             0, 1, 0, 2, 0, 6,
             1, 1, 7, 2, 0, 6,
             0, 1, 0, 2, 3, 6,
             3, 4, 3, 3, 5, 3,
             3, 4, 8, 3, 5, 3,
             3, 4, 3, 0, 5, 3);
$eject

  /****
   *
   *  read$invocation$line:
   *    reads the invocation line into .MEMORY, going past "&" and prompting
   *  for further input with "**" if required
   *
   ****/


  read$invocation$line: PROCEDURE;

    obufp = .memory;
    DO
      FOREVER;
      CALL console$in;
      DO
        WHILE (scan$byte <> '&');
        IF (termch) THEN
          DO;
            CALL out$char(0);        /* terminating null */
            scanp = .memory;
            RETURN;
          END;
        CALL out$scan$byte;
      ENDDO;
      CALL print(.('**',0));
    ENDDO;

  END read$invocation$line;
$eject

  /****
   *
   *  read$px$file$list:
   *    reads in the names of all the files containing definitions into
   *  the array IO$BUFF.  the list is terminated by a NULL.  leaves
   *  SCANP pointing to the character following the last filename
   *
   ****/


  read$px$file$list: PROCEDURE;

    obufp = .io$buff;
    DO
      WHILE (obufp < .io$buff(last(io$buff)));
      CALL scan$while$blanks;
      DO
        WHILE (filech);
        CALL out$scan$byte;
      ENDDO;
      CALL out$blank;               /* file names separated by BLANK */
      CALL scan$while$blanks;
      IF (scan$byte = ',') THEN
        CALL bump$scanp;
      ELSE
        DO;
          CALL out$char(0);       /* terminate list with empty filename */
          RETURN;
        END;
    ENDDO;
    CALL error$message(.('too many files in <px-file-list>',0));

  END read$px$file$list;
$eject

  /****
   *
   *  read$ch:
   *    bumps scanp.  if scan$ended is set, reads more data into the buffer.
   *  when an EOF occurs, scanp is set to point to a null string
   *
   ****/

  read$ch: PROCEDURE;

    CALL bump$scan$p;
    IF (scan$ended) THEN
      DO;
        CALL readi(.io$buff, size(io$buff)-1);
        IF (actual = 0) THEN
          DO;
            scanp = .NULL$STRING;
            CALL set$scan$ended;
            RETURN;
          END;
        io$buff(actual) = 0;
        scanp           = .io$buff;
        CALL set$scan$ended;
      END;

  END read$ch;



  /****
   *
   *  full$line:
   *    assures that there is a TERMCH in the string pointed to by
   *  scanp.  moves data and reads more if required
   *
   ****/

  full$line: PROCEDURE;

    DECLARE temp ADDRESS;

    temp = scanp;
    CALL scan$until(.termch);
    scanp = temp;
    IF (scan$ended) THEN
      DO;
        temp = .io$buff(last(io$buff)) - scanp;
        CALL fmove(temp, scanp, .io$buff);
        CALL readi(.io$buff(temp), size(io$buff) - temp - 1);
        io$buff(actual + temp) = 0;
        scanp = .io$buff;        /* should check long line ... */
      END;
  CALL set$scan$ended;

  END full$line;
$eject

  /****
   *
   *  init$memory:
   *    initializes available and mem$top
   *
   ****/


  init$memory: PROCEDURE;

    DECLARE (m BASED mem$top) BYTE;

    thread$head = .memory;
    available   = .memory;
    mem$top     = memck;
    m           = 0;
    mem$top     = mem$top - 1;

  END init$memory;
$eject

  /****
   *
   *  file$name$line:
   *    returns TRUE and sets file$name$buffer to the file name if scanp points
   *    to a string which specifies a file name.
   *
   ****/


  file$name$line: PROCEDURE BOOLEAN;

    IF (scan$byte <> '$') THEN
      RETURN (FALSE);
    CALL bump$scan$p;
    CALL scan$while$blanks;
    IF (NOT scan$match(.('FILE',0))) THEN
      RETURN (FALSE);
    CALL scan$while$blanks;
    IF (scan$byte <> '(') THEN
      RETURN (FALSE);
    CALL fill(size(file$name$buffer), .file$name$buffer, 0);
    CALL bump$scan$p;
    IF numeric$extension THEN  /* only save root */
      DO;
        CALL scan$while$blanks;
        CALL extract$root(.file$name$buffer);
        CALL scan$while(.file$ch);
        CALL scan$while$blanks;
      END;
    ELSE
      DO;
        IF scan$byte = ':' THEN
          scanp = scanp + 4;
        CALL move$file$name(.file$name$buffer);
      END;
    IF (scan$byte <> ')') THEN
      RETURN (FALSE);
    CALL set$sc(.file$name$buffer);
    CALL forc$up$string;
    RETURN (TRUE);

  END file$name$line;
$eject

  /****
   *
   *  pex$file$matches$file$name:
   *    returns TRUE IF the file name passed in matches the file name in File-
   *    NameBuffer.
   *
   ****/


  pex$file$matches$file$name: PROCEDURE (px$name$ptr) BOOLEAN;

    DECLARE px$name$ptr ADDRESS;
    DECLARE px$name BASED px$name$ptr CHAR;

    IF (px$name = ':') THEN
      px$name$ptr= px$name$ptr + 4;

    CALL set$sc(.file$name$buffer);
    IF scan$match(px$name$ptr) THEN
    DO;
      scanp = px$name$ptr;
      RETURN (scan$match(.file$name$buffer));
    END;
    RETURN false;

  END pex$file$matches$file$name;



  /****
   *
   *  check$gap:
   *    errors out should space overflow.
   *
   ****/


  check$gap: PROCEDURE;

    IF (available >= mem$top) THEN
      CALL error$message(.('dynamic storage overflow.  too many PEX symbols',0));

  END check$gap;
$eject

  /****
   *
   *  point$scanp$to$next$line:
   *    advances scanp to the first character after the current END of line.
   *
   ****/

  point$scanp$to$next$line: PROCEDURE;

    CALL scan$until(.termch);
    CALL scan$while(.termch);

  END point$scanp$to$next$line;



  /****
   *
   *  find$include$file:
   *    searches for the word INCLUDE, then copies the file name to
   *  the area pointed to by obufp
   *
   ****/

  find$include$file: PROCEDURE;

    CALL full$line;
    DO
      WHILE (NOT termch);
      CALL read$ch;
      IF (scan$match(.('INCLUDE',0))) OR (scan$match(.('IC',0))) THEN
        DO;
          CALL scan$until(.filech);
          CALL out$file$name(scanp);
          CALL out$char(0);
          CALL scan$until(.termch);
          include$count = include$count + 1;
          available     = obufp;
          CALL check$gap;
          RETURN;
        END;
      IF (scan$match(.('LEFTMARGIN',0))) OR (scan$match(.('LM',0))) THEN
        DO;
          CALL scan$until(.ddigch);
          left$margin = LOW(decin);
        END;
    ENDDO;

  END find$include$file;
$eject

  /****
   *
   *                 S Y M B O L   -   T A B L E   S E C T I O N
   *
   ****/

  /****
   *
   *  init$symbol$table:
   *    sets all the entries in the symbol table to NIL
   *
   ****/


  init$symbol$table: PROCEDURE;

    DECLARE i ADDRESS;

    i = length(symbol$table);
    DO
      WHILE (i <> 0);
      i = i - 1;
      symbol$table(i) = NIL;
    ENDDO;

  END init$symbol$table;
$eject

  /****
   *
   *  get$id:
   *    copies the symbol currently being pointed to into symbol$buffer, converting
   *    from lower to upper case and discarding '$'.  A maximum of 32 characters
   *    is allowed.  scanp is left pointing to the character which halted the
   *    scan.
   *
   ****/


  get$id: PROCEDURE;

    symbol$length = 0;
    CALL set$ob(.symbol$buffer);
    DO
      WHILE (NOT scan$ended);
      IF (toknch) THEN
        DO;
          CALL out$char(forcup);
          symbol$length = symbol$length + 1;
        END;
      ELSE IF (scan$byte <> '$') THEN
        GOTO exit$loop;
      CALL bump$scanp;
    ENDDO;

exit$loop:;
    IF (symbol$length > SYMBOL$MAX) THEN
      CALL error$message(.('symbol greater than 40 characters long',0));

    CALL out$char(0);

  END get$id;
$eject

  /****
   *
   *  hash:
   *    sets hash$value to the hashed value of symbol$buffer;
   *
   ****/

  hash: PROCEDURE;

    DECLARE i BYTE;

    i = 0;
    CALL set$sc(.symbol$buffer);
    CALL set$scan$ended;
    DO
      WHILE (NOT scan$ended);
      i = i + scan$byte;
      CALL bump$scan$p;
    ENDDO;

    hash$value = i;

  END hash;



  /****
   *
   *  lookup$id:
   *    searches the symbol table for the entry with ID = symbol$buffer.
   *
   ****/


  lookup$id: PROCEDURE ADDRESS;

    DECLARE ptr         ADDRESS,
            p BASED ptr SYMBOL$TABLE$ENTRY;

    CALL hash;
    ptr = symbol$table(hash$value);
    CALL set$sc(0);
    DO
      WHILE (ptr <> NIL);
      scanp = .symbol$buffer;           /* this is NOT string equality */
      IF (scan$match(.p.STR(0))) THEN
        IF (scan$byte = 0) THEN
          RETURN (ptr);
      ptr = p.NEXT;
    ENDDO;

    RETURN (NIL);

  END lookup$id;
$eject

  /****
   *
   *  insert$pex$symbol:
   *    the string pointed to by scanp is inserted into the symbol table.
   *    NOTE:  the symbol tables grow towards mem$top from available.
   *
   ****/


  insert$pex$symbol: PROCEDURE (mark$value);

    DECLARE mark$value BYTE;

    DECLARE pex$data$string$ptr    ADDRESS,
            ste$p                  ADDRESS,
            ste$b BASED ste$p      SYMBOL$TABLE$ENTRY,
            pex$data$string$length ADDRESS;

    CALL get$id;
    CALL scan$while$blanks;
    pex$data$string$ptr = scanp;
    CALL scan$until(.termch);
    pex$data$string$length = scanp - pex$data$string$ptr;

    ste$p = available;
    obufp = .ste$b.STR(0);
    CALL out$print(.symbol$buffer);
    CALL out$char(0);
    CALL out$write(pex$data$string$ptr, pex$data$string$length);
    CALL out$char(0);
    available = obufp;
    CALL check$gap;

    CALL hash;
    ste$b.NEXT   = symbol$table(hash$value);
    ste$b.MARK   = mark$value;
    ste$b.THREAD = available;

    symbol$table(hash$value) = ste$p;

  END insert$pex$symbol;
$eject

  /****
   *
   *  mark$internal$references:
   *    assures that symbols containing references to other symbols (BASEd var-
   *    iables and literallys) are included in the declarations.
   *
   ****/


  mark$internal$references: PROCEDURE (mark$value, str$p) REENTRANT;

    DECLARE mark$value BYTE,
            str$p      ADDRESS;

    DECLARE save$scanp ADDRESS;

    save$scanp = scanp;
    scanp      = str$p;
    DO
      WHILE (scan$byte <> 0);
      IF (scan$byte = '.') THEN
        CALL find$and$mark(mark$value);
      ELSE IF ((scan$byte = '"') OR (scan$byte = '''')) THEN        /* only one level is allowed */
        DO
          WHILE (scan$byte <> 0);
          CALL find$and$mark(mark$value);
        ENDDO;
      CALL bump$scan$p;
    ENDDO;
    scanp = save$scanp;

  END mark$internal$references;
$eject

  /****
   *
   *  mark$id:
   *    looks up the symbol in symbol$buffer.  If found, sets MARK to the passed
   *    in value.
   *
   ****/


  mark$id: PROCEDURE (mark$value) REENTRANT;

    DECLARE mark$value BYTE;

    DECLARE ste$p             ADDRESS,
            ste$b BASED ste$p SYMBOL$TABLE$ENTRY,
            save$scanp        ADDRESS;

    save$scanp = scanp;
    ste$p = lookup$id;
    IF (ste$p <> NIL) THEN
      IF (ste$b.MARK <> mark$value) THEN
        DO;
          ste$b.MARK = mark$value;
          CALL mark$internal$references(mark$value, .ste$b.STR(1) + lenstrnul(.ste$b.STR));
          ste$p = ste$b.NEXT;
          DO
            WHILE (ste$p <> NIL);
            scanp = .symbol$buffer;
            IF (scan$match(.ste$b.STR(0))) THEN
              IF (scan$byte = 0) THEN
                DO;
                  ste$b.MARK = mark$value;
                  CALL mark$internal$references(mark$value, .ste$b.STR(1) + lenstrnul(.ste$b.STR));
                END;
            ste$p = ste$b.NEXT;
          ENDDO;
        END;
    scanp = save$scanp;

  END mark$id;



  /****
   *
   *  find$and$mark:
   *    bump scanp to the next letter, get the symbol and set its mark field to
   *    the passed in value.
   *
   ****/


  find$and$mark: PROCEDURE (mark$value) REENTRANT;

    DECLARE mark$value BYTE;

    CALL scan$until(.toknch);
    CALL get$id;
    CALL mark$id(mark$value);

  END find$and$mark;
$eject

  /****
   *
   *  flush$io$buff:
   *    dumps io$buff to the output file
   *
   ****/


  flush$io$buff: PROCEDURE;
  
    CALL writeo(.io$buff, io$buff$idx);
    io$buff$idx = 0;

  END flush$io$buff;




  /****
   *
   *  write$char:
   *    writes the character to the output file
   *
   ****/


  write$char: PROCEDURE (ch);

    DECLARE ch CHAR;

    io$buff(io$buff$idx) = ch;
    io$buff$idx          = io$buff$idx + 1;
    IF (io$buff$idx > last(io$buff)) THEN
      CALL flush$io$buff;
    chars$on$line = chars$on$line + 1;

  END write$char;



  /****
   *
   *  write$string:
   *    writes the null terminated string to the output file
   *
   ****/


  write$string: PROCEDURE (s$p);

    DECLARE s$p ADDRESS;

    CALL setsc(s$p);
    DO
      WHILE (scan$byte <> 0);
      CALL write$char(scan$byte);
      CALL bump$scan$p;
    ENDDO;

  END write$string;
$eject

  /****
   *
   *  write$number:
   *    writes the decimal ADDRESS using write$char.
   *
   ****/


  write$number: PROCEDURE (number);

    DECLARE number ADDRESS;

    DECLARE nbuff(6) CHAR;

    CALL fill(6, .nbuff, 0);
    CALL set$ob(.nbuff);
    CALL out$dec(number);
    CALL write$string(.nbuff);

  END write$number;
$eject

  write$declare: PROCEDURE;
    CALL write$string(.('declare ',0));
  END write$declare;

  write$semi: PROCEDURE;
    CALL write$char(';');
  END write$semi;

  write$comma: PROCEDURE;
    CALL write$char(',');
  END write$comma;

  write$lp: PROCEDURE;
    CALL write$char('(');
  END write$lp;

  write$rp: PROCEDURE;
    CALL write$char(')');
  END write$rp;

  write$crlf: PROCEDURE;
    CALL write$string(.(CR,LF,0));
    chars$on$line = 0;
  END write$crlf;

  write$left$margin: PROCEDURE;
    DECLARE i BYTE;
    IF left$margin = 0 THEN RETURN;
    i = left$margin - 1;
    DO WHILE i > 0;
      CALL write$char(' ');
      i = i - 1;
    END;
  END;


  /****
   *
   *  write$lit:
   *    writes the definition as a literally statement.
   *
   ****/


  write$lit: PROCEDURE;

    CALL write$left$margin;
    CALL write$declare;
    CALL write$string(.symbol$buffer);
    CALL write$string(.(' literally ',0));
    CALL write$string(scanp);
    CALL write$semi;
    CALL write$crlf;

  END write$lit;
$eject

  /****
   *
   *  chr$idx:
   *    returns an index of the character pointed to by scanp.
   *
   ****/


  chr$idx: PROCEDURE (s$p) ADDRESS;

    DECLARE s$p ADDRESS;

    DECLARE i             BYTE,
            s$b BASED s$p CHAR,
            ch            CHAR;

    i  = 1;
    ch = forcup;
    DO
      WHILE (s$b <> 0);
      IF (s$b = ch) THEN
        RETURN (i);
      s$p = s$p + 1;
      i   = i + 1;
    ENDDO;

    RETURN (0);

  END chr$idx;
$eject

  /****
   *
   *  quote$ch:
   *    returns TRUE if the scan$byte is a '"'
   *
   ****/


  quote$ch: PROCEDURE BOOLEAN;

    RETURN (scan$byte = '"');

  END quote$ch;



  /****
   *
   *  err$msg$flush:
   *    flushes the io$buff (to the IPX file) before reporting error and exit
   *
   ****/

  err$msg$flush: PROCEDURE(ptr);
    DECLARE ptr ADDRESS;
    CALL flush$io$buff;
    CALL error$message(ptr);
  END;




  /****
   *
   *  copy$to$symbol$buffer:
   *    copies into symbol$buffer from scanp until a '"' is seen.  appends
   *  a null onto the end
   *
   ****/

  copy$to$symbol$buffer: PROCEDURE;

    CALL bump$scan$p;
    CALL setob(.symbol$buffer);
    CALL out$blank;
    CALL scan$while$blanks;
    DO
      WHILE (NOT quote$ch);
      IF (scan$ended) THEN
        CALL err$msg$flush(.('trailing ''"'' left off of declaration',0));
      CALL out$scan$byte;
    END;
    CALL out$char(0);

  END copy$to$symbol$buffer;
$eject

  /****
   *
   *  write$var:
   *    writes a declaration for the variable with the given type.
   *
   ****/


  write$var: PROCEDURE;

    DECLARE TYPE$TBL(*) CHAR DATA('ABIWDS@R"L',0),
            TYPE$PTR(*) ADDRESS DATA(
              .NULL$STRING,
              .ADDRESS$VARIABLE$STRING,
              .BYTE$VARIABLE$STRING,
              .INTEGER$VARIABLE$STRING,
              .WORD$VARIABLE$STRING,
              .dword$variable$string,
              .selector$variable$string,
              .POINTER$VARIABLE$STRING,
              .REAL$VARIABLE$STRING,
              .symbol$buffer,
              .LABEL$STRING),
            idx ADDRESS,
      (based$ptr, array$ptr, bvar$ptr) ADDRESS;

    CALL write$left$margin;
    CALL write$declare;
    CALL write$string(.symbol$buffer);
    CALL set$ob(.symbol$buffer);
    idx = chr$idx(.TYPE$TBL);
    IF (scan$byte = '"') THEN
      CALL copy$to$symbol$buffer;
    CALL bump$scan$p;
$eject

    based$ptr, array$ptr, bvar$ptr= .NULL$STRING;
    DO
      WHILE (NOT scan$ended);

      CALL scan$while$blanks;
      IF (forcup = 'S') THEN
        DO;
          array$ptr = .('(1)',0);
          CALL bump$scan$p;
        END;
      ELSE IF (scan$addr = '..') THEN
        DO;
           based$ptr       = .(' BASED ',0);
           scanp, bvar$ptr = scanp + 2;
           CALL scan$until(.blnkch);
           IF (NOT scan$ended) THEN
             DO;
               scan$byte = 0;
               scanp     = scanp + 1;
             END;
        END;
      ELSE IF (NOT scan$ended) THEN
        DO;
          CALL print(scanp);
          CALL err$msg$flush(.('bad pex line',0));
        END;
    ENDDO;

    CALL write$string(based$ptr);
    CALL write$string(bvar$ptr);
    CALL write$string(array$ptr);

    CALL write$string(TYPE$PTR(idx));
    IF (bvar$ptr = .NULL$STRING) THEN
      CALL write$string(.EXTERNAL$STRING);
    CALL write$semi;
    CALL write$crlf;
  END write$var;
$eject

  /****
   *
   *  pex$error:
   *    prints an error message on the terminal and exits.
   *
   ****/


  pex$error:
    PROCEDURE;

    CALL print$cr(.('bad PEX line',0));
    CALL print(.symbol$buffer);
    CALL put$blank;
    CALL print$cr(scanp);
    CALL flush$io$buff;
    CALL ex;

  END pex$error;
$eject

  /****
   *
   *  write$proc:
   *    writes the declaration of a procedure.  The format of a procedure declar-
   *    ation is p[argument-list][type].  argument-list is either a string of
   *    '1' or '2', or '(' type-characters ')'.  type is type-character.
   *    type-character is one of the characters '@RIWAB"'.
   *
   ****/


  write$proc: PROCEDURE;

    DECLARE PARAM$TYPE$STRING(*)     CHAR DATA('ABWDS@IR"21',0),
            PARAM$1$2$TYPE$STRING(2) CHAR AT(.PARAM$TYPE$STRING(9)),
            PARAM$TYPE$TBL(*)        ADDRESS DATA(
              .NULL$STRING,
              .ADDRESS$VARIABLE$STRING,
              .BYTE$VARIABLE$STRING,
              .WORD$VARIABLE$STRING,
              .dword$variable$string,
              .selector$variable$string,
              .POINTER$VARIABLE$STRING,
              .INTEGER$VARIABLE$STRING,
              .REAL$VARIABLE$STRING,
              .symbol$buffer,
              .ADDRESS$VARIABLE$STRING,
              .BYTE$VARIABLE$STRING),
            ZZ$STRING(*)     CHAR DATA('ZZ',0),
            saved$scanp      ADDRESS,
            arg$end          ADDRESS,
            (i, j, params)   ADDRESS;

    check$line$len: PROCEDURE;
      IF chars$on$line > 71 THEN
        DO;
          CALL write$crlf;
          CALL write$left$margin;
          CALL write$string(.('  ',0));
        END;
    END;

    write$args: PROCEDURE (p);
      DECLARE p ADDRESS;
      CALL write$lp;
      DO
        FOREVER;
        CALL write$string(.ZZ$STRING);
        params = params + 1;
        CALL write$number(params);
        IF (quote$ch) THEN
          DO;
            CALL bump$scan$p;
            CALL scan$until(.quote$ch);
          END;
        CALL bump$scan$p;
        IF (chr$idx(p) = 0) THEN
          DO;
            CALL write$rp;
            RETURN;
          END;
        CALL write$comma;
        CALL check$line$len;
      ENDDO;
    END write$args;
$eject

    chars$on$line = 0;
    CALL bump$scan$p;
    CALL write$left$margin;
    CALL write$string(.symbol$buffer);
    CALL write$string(.(':procedure',0));
    params = 0;
    CALL scan$while$blanks;
    IF (scan$byte = '(') THEN
      DO;
        CALL bump$scan$p;
        saved$scanp = scanp;
        CALL write$args(.PARAM$TYPE$STRING);
        arg$end = scanp;
        IF (scan$byte <> ')') THEN
          CALL err$msg$flush(.('Missing closing '')'' in procedure definition',0));
        CALL bump$scan$p;
      END;
    ELSE IF ((scan$byte = '1') OR (scan$byte = '2')) THEN
      DO;
        saved$scanp = scanp;
        CALL write$args(.PARAM$1$2$TYPE$STRING);
        arg$end = scanp;
      END;
$eject

    CALL set$scan$ended;
    CALL scan$while$blanks;
    IF (quote$ch) THEN
      CALL copy$to$symbol$buffer;
    CALL write$string(PARAM$TYPE$TBL(chr$idx(.PARAM$TYPE$STRING)));
    CALL write$string(.EXTERNAL$STRING);
    CALL write$semi;
    CALL check$line$len;

    IF (params <> 0) THEN
      DO;
        CALL write$declare;
        scanp = saved$scanp;
        j     = 1;
        DO
          WHILE (scanp < arg$end);
          CALL write$string(.ZZ$STRING);
          CALL write$number(j);
          IF (scan$byte = '"') THEN
            CALL copy$to$symbol$buffer;
          CALL write$string(PARAM$TYPE$TBL(chr$idx(.PARAM$TYPE$STRING)));
          CALL bump$scan$p;
          j      = j + 1;
          params = params - 1;
          IF (params <> 0) THEN
            DO;
              CALL write$comma;
              CALL check$line$len;
            END;
          ELSE
            CALL write$semi;
        ENDDO;
      END;

    CALL write$string(.('end;',CR,LF,0));

  END write$proc;
$eject

  /****
   *
   *  write$dcl:
   *    The symbol being defined is placed into symbol$buffer.  The first
   *    non-blank character of the definition string (pointed to by
   *    id$text$ptr) is used to determine whether a variable, procedure
   *    or literal declaration is to be produced.
   *
   ****/


  write$dcl: PROCEDURE (id$p, id$text$p);

    DECLARE (id$p, id$text$p) ADDRESS;

    DECLARE prc           ADDRESS,
            PROC$TABLE(*) ADDRESS DATA(
              .pex$error,                  /* unknown character */
              .write$proc,                 /*  P  */
              .write$var,                  /*  A  */
              .write$var,                  /*  B  */
              .write$lit,                  /*  '  */
              .write$var,                  /*  @  */
              .write$var,                  /*  R  */
              .write$var,                  /*  W  */
              .WRITE$VAR,                  /*  d  */
              .WRITE$VAR,                  /*  s  */
              .write$var,                  /*  i  */
              .write$var,                  /*  "  */
              .write$var);                 /*  L  */

    scanp = id$text$p;
    CALL set$scan$ended;
    obufp = .symbol$buffer;
    CALL out$print(id$p);
    CALL out$char(0);
    CALL scan$while$blanks;
    prc = PROC$TABLE(chr$idx(.('PAB''@RWDSI"L',0)));
    CALL prc;

  END write$dcl;
$eject

  /****
   *
   *  dump$dcls:
   *    writes the declarations for all those entries whose MARK field
   *  is equal to MARK$VALUE
   *
   ****/


  dump$dcls: PROCEDURE (mark$value);

    DECLARE mark$value BYTE;

    DECLARE s$p           ADDRESS,
            sym$p         ADDRESS,
            col           BYTE,
            len           BYTE,
            s$b BASED s$p SYMBOL$TABLE$ENTRY;

    s$p = thread$head;
    col = 0;
    CALL put$crlf;
    DO
      WHILE (s$p < thread$end);
      IF (s$b.MARK = mark$value) THEN
        DO;
          sym$p = .s$b.STR;
          len   = lenstrnul(sym$p) + 1;
          col   = col + len;
          IF (col > 78) THEN            /* line end */
            DO;
              col = len;
              CALL put$crlf;
            END;
          CALL print(sym$p);
          CALL put$blank;
          CALL write$dcl(sym$p, sym$p + len);
        END;
      s$p = s$b.THREAD;
    ENDDO;
    CALL flush$io$buff;

  END dump$dcls;
$eject

  /****
   *
   *  class:
   *    returns the class of scan$byte
   *
   ****/


  class: PROCEDURE ADDRESS;

    IF (letrch) THEN
      RETURN (5);
    RETURN (chr$idx(.(LF,'$/*',0)));     /* all others are class 0 */

  END class;
$eject

  /****
   *
   *  Main module:
   *    initialize memory and symbol table.
   *    read in command line and get filenames for SRC$FILE and PX$FILEs.
   *    read in PX$FILEs, creating symbol table with all entries UNMARKed.
   *    read in SRC$FILE
   *    for each token until the END of the file, set its ste$b as MARKed.
   *    delete all UNMARKed STEs.
   *    transform the symbol table to preserve space.
   *    open SRC$FILE.IPX
   *    write the declarations.
   *    exit.
   *
   ****/


  FATAL, REPORT = TRUE;           /* blab about errors */
  CALL read$invocation$line;
  CALL read$px$file$list;
  CALL scan$while$blanks;
  CALL scan$expect(.('TO',0));
  CALL scan$while$blanks;
  CALL forc$up$string;
  CALL extract$root(.src$root);
  CALL move$file$name(.src$file);
  CALL ISIS(spath,.spath$parm$blk);
  scanp = .spath$buf(7);  /* first extension char */
  CALL scan$while(.ddigch);
  numeric$extension = (scanp = .spath$buf(10));
$IF XVERSION
  CALL printcr(.(CR,LF,'ISIS-II GENPEX X108',CR,LF,0));
$ELSE
  CALL printcr(.(CR,LF,'ISIS-II GENPEX V1.1',CR,LF,0));
$ENDIF
  CALL init$memory;
  CALL init$symbol$table;
$eject

  DO
    WHILE (lenstrnul(px$file$list$p) <> 0);

    scanp  = px$file$list$p;      /* get next file name in list */
    report = FALSE;               /* turn off error reporting   */
    CALL open$scan(.openi);       /* open it, advancing SCANP   */
    report = TRUE;                /* error report & bomb out if */
    IF (status <> 0) THEN         /* file couldn't be opened    */
      CALL file$error$message(.('could not open',0), px$file$list$p);

    CALL print(.('reading ',0));  /* display file name          */
    CALL writec(px$file$list$p, scanp - px$file$list$p);
    px$file$list$p = scanp + 1;   /* and remember new position  */
    CALL put$crlf;

    /* read in the <px-file> */
    CALL readi$with$limit(available, mem$top - available + 1);
    CALL closei;
    CALL fmove(actual, available, (scanp := mem$top - actual + 1));

    put$symbol$flag = TRUE;
    CALL set$scan$ended;
    DO
      WHILE (NOT scan$ended);
      IF (toknch) THEN
        DO;
          IF (put$symbol$flag) THEN
            CALL insert$pex$symbol(UNMARKED);
        END;
      ELSE IF (file$name$line) THEN
        DO;
          IF numeric$extension THEN  /* only match root */
            put$symbol$flag = NOT pex$file$matches$file$name(.src$root);
          ELSE
            put$symbol$flag = NOT pex$file$matches$file$name(.src$file);
        END;
      CALL point$scanp$to$next$line;
    ENDDO;
  ENDDO;
  thread$end = available;
$eject

  /*
   * scan the source file for identifiers appearing in the symbol table
   * and mark the symbol table entries as being used.
   */

  scanp = .src$file;              /* create the .IPX file name       */
  CALL new$extension(.ipx$file, .('IPX',0));
  REPORT, FATAL = FALSE;          /* make no noise if it isn't there */
  CALL del(.ipx$file);            /* delete previous .IPX file       */
  REPORT, FATAL = TRUE;
  CALL print(.('- - - -',CR,LF,'source: ',0));
  CALL printcr(.src$file);
  CALL openi(.src$file);
  include$begin, obufp = available;     /* remember file names here */
  scanp                = .NULL$STRING;  /* cause READ$CH to read in data */
  DO
    FOREVER;
    CALL read$ch;
    IF (scan$ended) THEN
      DO;
        CALL closei;
        status        = 0FFH;
        fatal,report  = FALSE;
        DO                /* open include files */
          WHILE (status <> 0);
          IF (include$count = 0) THEN
            DO;
              fatal, report = TRUE;
              GOTO exit$loop;
            END;
          include$count = include$count - 1;
          scanp         = include$begin;
          CALL print(.('source: ',0));
          CALL print$cr(scanp);
          CALL open$scan(.openi);
          include$begin = scanp + 1;
        ENDDO;
        fatal, report = TRUE;
        scanp         = .NULL$STRING;
      END;
    ELSE
      DO;
        state = fsm(state).NEXT(class);
        IF (state = 6) THEN
          DO;
            CALL full$line;
            CALL find$and$mark(MARKED);
            state = 0;
          END;
        ELSE IF (state > 6) THEN
          DO;
            CALL find$include$file;
            IF (state = 8) THEN
              state = 3;     /* continue scanning comment */
            ELSE
              state = 0;     /* otherwise start again */
          END;
      END;
  ENDDO;
exit$loop:;
$eject

  /*
   * write the declarations
   */

  CALL openo(.ipx$file);
  CALL dump$dcls(MARKED);

  CALL put$crlf;
  CALL ex;

END npex;