{***************************************************************************}
{* This program is a general purpose PAL assembler. You may copy and use   *}
{* it for personal purposes. No commercial use of this program is allowed  *}
{* without the consent of the author.                                      *}
{* THIS IS THE Atari ST Version                                            *}
{* (c) Copyright 1987,1988 by Erasmo Brenes.                               *}
{***************************************************************************}
program passm (input,output,source,simfile);
 const
  linewidth = 40;
  blank = ' ';  semicol = ';';  comment = '"';
  maxterms = 19;        maxinputs = 22;
  maxpins = 24;         npals   = 23;
  maxcols = 44;         maxouts = 10;

 type
  symbol =( ident, int, num, eql, quotes, semicolon, apostrophe,
            leftbrkt, rightbrkt, device, pin, equations,module,flag,
            lftparen,rgtparen,title,node,stype,macro,andoperator,
            oroperator,invert,colon,ends,enable,preset,clear);
  palsymb = ( p10l8,p12l6,p14l4,p16l2,p16l8,p16rx,p12l10,p14l8,p16l6,
              p18l4,p20l2,p20l10,p20l8,p20rx,p22vx);
  tkens = packed array [1..15] of char;
  kind  = (reg, nonreg, bidir, tristate);
  palsize = (input18, input22);
  logic = (high, low);
  trans1typ =
   record
        transfer : array[1..maxpins] of integer
   end;
  outtype =
   record
        outnumb : integer;
        outname : tkens;
        outkind : kind;
        size    : palsize;
        form    : logic;
        matrix  : array [1..maxterms,1..maxcols] of char
   end;
  entrytype =
   record
        name : tkens;
        pinn : integer
   end;
  string2 = packed array [1..4] of char;
  filnam = packed array [1..80] of char;
  ptermtyp = array [1..maxcols] of char;

 var
  source,simfile : text;
  token  : tkens;
  palknds : array [1..npals] of char;
  pals    : array [1..npals] of tkens;
  symtable: array [1..maxpins] of entrytype;
  outtable: array [1..11] of outtype;
  palkind : palsymb;
  fusetoinp,fusetopin : array [palsymb] of trans1typ;
  paltyp  : array [1..npals] of palsymb;
  filspc : string[80];
  sym : symbol;
  reserved : array [1..13] of tkens;
  pdevice : tkens;
  wsym : array [1..13] of symbol;
  ptype,ch,tab : char;
  nexout,outindex : integer;
  nexin : integer;
  value,i,j,pointer,iterm,totalterms : integer;
  Abort,empty,pal16,found : boolean;
  ar, sp : ptermtyp;

 procedure bgetchar (var ch:char);
  begin
   empty := false;
   if eof(source)
    then begin
          empty := true;
          ch := blank
         end
    else begin
          if eoln(source)
           then begin
                 readln (source);
                 ch := blank
                end
           else
          if eof(source)
           then begin
                 empty := true;
                 ch := blank
                end
           else begin
                 read (source,ch);
                 if ch = comment
                  then begin
                        repeat
                        readln (source);
                        if eof(source)
                         then begin
                                empty := true;  ch := blank
                              end
                         else read (source,ch)
                        until (ch <> comment) or (eof(source))
                       end
                end
         end
  end; {bgetchar}

 procedure numbr;
{this routine always leaves with ch containing the next character!}
  var
   j : integer;
  begin
   sym := int;
   value := 0;  j:= 0;
   repeat
    value := 10*value + (ord(ch) - ord('0'));
    bgetchar (ch);       j:= j + 1
   until not(ch in ['0'..'9'])
  end; {numbr}

 procedure gettoken;
  var
   i,j,k : integer;
  begin
   i:= 0;
   while ((ch=blank)or(ch=tab))and(not empty) do bgetchar(ch);
   if (ch in ['A'..'Z'])or(ch in['a'..'z'])or(ch = '-')
    then begin
          repeat
           i:= i + 1;
           token [i]:= ch;      bgetchar(ch)
          until not((ch in ['A'..'Z'])or(ch in['a'..'z'])or(ch in ['0'..'9'])
           or (ch='_')) or empty or (i = 15);
          if not empty
           then begin
                 if (i < 15) then repeat
                                   i:= i + 1; token[i]:= blank
                                  until (i=15);
                 k := 0;
                 for j:=1 to 13 do
                  if token = reserved[j]
                   then k := j;
                 if k = 0
                  then sym := ident
                  else sym := wsym [k]
                end
         end
    else begin
          if (ch in ['0'..'9'])
           then numbr
           else case ch of
                 '^':  begin
                        sym := num;
                        bgetchar (ch)
                       end;
                 '=':  begin
                        sym := eql;
                        bgetchar (ch)
                       end;
                 ';':  begin
                        sym := semicolon;
                        bgetchar (ch)
                       end;
                 '''': begin
                        sym := apostrophe;
                        bgetchar (ch)
                       end;
                 '`':  begin
                        sym := apostrophe;
                        bgetchar (ch)
                       end;
                 '"':  begin
                        sym := quotes;
                        bgetchar (ch)
                       end;
                 '[':  begin
                        sym := leftbrkt;
                        bgetchar (ch)
                       end;
                 ']':  begin
                        sym := rightbrkt;
                        bgetchar (ch)
                       end;
                 '(':  begin
                        sym := lftparen;
                        bgetchar (ch)
                       end;
                 ')':  begin
                        sym := rgtparen;
                        bgetchar (ch)
                       end;
                 '!':  begin
                        sym := invert;
                        bgetchar (ch)
                       end;
                 '&':  begin
                        sym := andoperator;
                        bgetchar (ch)
                       end;
                 '#':  begin
                        sym := oroperator;
                        bgetchar (ch)
                       end;
                 ':':  begin
                        sym := colon;
                        bgetchar (ch)
                       end;
                 otherwise:
                    begin
                     bgetchar (ch);
                     gettoken { get next token }
                    end
                end
         end
  end; {gettoken}

 procedure semimodule;
  begin
   gettoken;
   while sym = semicolon
    do gettoken;
  end;

 procedure search ( kind : integer);
  var
   i,j : integer;
  begin
   case kind of
    1:   begin
          pointer := 0;
          for i:=1 to npals do
           if token = pals[i]
            then pointer := i
         end;
    2:  begin
         j := pointer;
         pointer := 0;
         for i:=1 to 24 do
          with symtable[i] do
           if pinn = j
            then pointer := i
        end;
    3:  begin      { search a signal name for its corresponding pin }
         pointer := 0;  found := false;
         for i:= 1 to maxpins do
          with symtable[i] do
           if token = name
            then begin
                  pointer := pinn; found := true
                 end
        end;
    otherwise:
        writeln ('!!! software error in search procedure')
   end
  end; {search}

 procedure start;
  var
   first : integer;
  begin
   while not(sym = equations) and (not Abort) and not(eof(source))do
    begin
     first := nexin + 1;
     if sym = ident
      then begin
            nexin := nexin + 1;
            symtable[nexin].name := token;
            gettoken;
            while sym = ident do
             begin      { get list of identifiers }
              nexin := nexin + 1;
              symtable[nexin].name := token;
              gettoken
             end;
            case sym of
             device: begin
                      nexin := first - 1;  {ignore all previous identifiers}
                      gettoken;
                      if sym = apostrophe
                       then begin
                             gettoken;
                             search (1);
                             if pointer = 0
                              then begin
                                    writeln ('** not a valid part ',token);
                                    Abort := true
                                   end
                              else begin
                                    pdevice := token;
                                    ptype := palknds[pointer];
                                    palkind := paltyp [pointer];
                                    gettoken;
                                    if sym = apostrophe
                                     then gettoken;
                                    if sym = semicolon
                                     then gettoken
                                     else Abort := true {screw the idiot***}
                                   end
                            end
                     end;
             pin:    begin
                      gettoken; { it must be a pin number }
                      while not(sym = int) do gettoken;
                      repeat
                       symtable[first].pinn := value;
                       first := first + 1;
                       gettoken
                      until first > nexin;
                      if sym = semicolon
                       then gettoken
                       else Abort := true       {screw the idiot ***}
                     end;
             otherwise:
                     begin
                      nexin := first - 1;
                      while not (sym = semicolon)
                        do gettoken;
                      gettoken
                     end
            end
           end
    end
  end;   {start}

 procedure titlemodule;
  begin
   gettoken;
   if sym = apostrophe
    then begin
          repeat
           gettoken
          until sym = apostrophe;
          gettoken;
          if sym = semicolon
           then begin
                 semimodule;
                 start
                end
           else start
         end
    else begin
          writeln ('** illegal construct for the title section');
          Abort := true
         end
  end;  {titlemodule}

 procedure flagmodule;
  begin
   gettoken;
   if sym = apostrophe
    then begin
          repeat
           gettoken
          until sym = apostrophe;
          gettoken;
          case sym of
           title : titlemodule;
           semicolon: begin
                        semimodule;
                        if sym = title
                         then titlemodule
                         else start
                      end;
           otherwise:
                start
          end
         end
    else begin
          writeln ('** illegal construct for the flag section');
          Abort := true
         end
  end;  {flagmodule}

 procedure arguments;
  begin
   gettoken;
   case sym of
    ident : begin
             gettoken;
             while not(sym = rgtparen)
              do gettoken;
             gettoken;
             case sym of
              flag : flagmodule;
              title: titlemodule;
              semicolon: begin
                          semimodule;
                          if sym = flag
                           then flagmodule
                           else if sym = title
                                 then titlemodule
                                 else start
                         end;
              otherwise:
                begin
                 writeln ('** illegal path after module arguments');
                 Abort := true
                end
             end
            end;
    rgtparen: begin
                gettoken;
                case sym of
                 flag : flagmodule;
                 title: titlemodule;
                 semicolon: begin
                             semimodule;
                             if sym = flag
                              then flagmodule
                              else if sym = title
                                    then titlemodule
                                    else start
                            end;
                 otherwise:
                        start
                end
              end;
    otherwise:
        begin
         writeln ('** missing right parenthesis in dummy argument list');
         Abort := true
        end
   end
  end;   {arguments}

 procedure getnames;
  begin
   gettoken;
   while not((sym = module))and (not empty)
    do gettoken;
   gettoken;
   if sym = ident
    then begin
          gettoken;
          case sym of
           lftparen :   arguments;
           flag:        flagmodule;
           title:       titlemodule;
           semicolon:   begin
                         semimodule;
                         case sym of
                          flag : flagmodule;
                          title: titlemodule;
                          otherwise:
                            start
                         end
                        end;
           otherwise:
             start
          end
         end
    else begin
          Abort := true;
          writeln ('** missing module name')
         end
  end; {getnames}

 procedure error (errnmbr : integer);
  begin
   case errnmbr of
    1 : begin
         writeln ('Signal name undefined: ',token)
        end;
    2 : begin
         writeln ('error in andoperator!')
        end;
    3 : begin
         writeln ('Expecting a signal name');
         writeln ('Undetermined token ',token)
        end;
    4 : begin
         writeln ('Expecting a "=" operator');
         writeln ('Got instead ',token)
        end;
    5 : begin
         writeln ('Expecting either a ":" or "=" operator');
         writeln ('Instead it got ',token)
        end;
    6 : begin
         writeln ('Expecting a boolean equation');
         writeln ('Unexpected token ',token)
        end;
    7 : begin
         writeln ('Exceeded total or-terms');
         writeln ('Output =',outtable[nexout].outname);
        end;
    8 : begin
         writeln (token,' not a valid input or feedback factor')
        end;
    9 : begin
         writeln ('Expecting ";" at end of equation')
        end;
   10 : begin
         writeln ('This device is not capable of this function')
        end;
   11 : begin
         writeln ('This device is not capable of true-form output ',token)
        end;
   12 : begin
         writeln ('Not a valid output pin for ',token);
        end;
    otherwise:
        writeln ('software error in error routine')
   end
  end; {error}

 procedure andterm;
  begin
   gettoken;
   case sym of
    ident :
     begin
      search (3);     {find pin number attached to this signal name}
      if not found
       then begin error(1); gettoken end
       else begin
             j := fusetoinp[palkind].transfer[pointer]; {get fuse number}
             if j < 0
              then error (8)   {not a valid input or feedback factor}
              else outtable[outindex].matrix[iterm,j]:= '1';
             gettoken;
             if sym = andoperator then andterm  {call back recursively}
            end
     end;
    invert :
     begin
      gettoken;     {get signal name}
      if sym = ident
       then
        begin
         search (3);     {find pin number attached to this signal name}
         if not found
          then begin error(1); gettoken end
          else begin
                j := fusetoinp[palkind].transfer[pointer]; {get fuse number}
                if j < 0
                 then error (8)   {not a valid input or feedback factor}
                 else begin
                       j := j + 1;    {increment fuse number}
                       outtable[outindex].matrix[iterm,j]:= '1'
                      end;
                gettoken;
                if sym = andoperator then andterm  {call back recursively}
               end
        end
       else error (3)   {expecting an identifier, i.e. signal name}
     end;
    otherwise:  error (2)
   end
  end; {andterm}

 procedure nodeterm (var pterm : ptermtyp);
  begin
   gettoken;
   case sym of
    ident :
     begin
      search (3);     {find pin number attached to this signal name}
      if not found
       then begin error(1); gettoken end
       else begin
             j := fusetoinp[palkind].transfer[pointer]; {get fuse number}
             if j < 0
              then error (8)   {not a valid input or feedback factor}
              else pterm[j]:= '1';
             gettoken;
             if sym = andoperator then nodeterm(pterm)  {call back recursively}
            end
     end;
    invert :
     begin
      gettoken;     {get signal name}
      if sym = ident
       then
        begin
         search (3);     {find pin number attached to this signal name}
         if not found
          then begin error(1); gettoken end
          else begin
                j := fusetoinp[palkind].transfer[pointer]; {get fuse number}
                if j < 0
                 then error (8)   {not a valid input or feedback factor}
                 else begin
                       j := j + 1;    {increment fuse number}
                       pterm[j]:= '1'
                      end;
                gettoken;
                if sym = andoperator then nodeterm(pterm)
               end
        end
       else error (3)   {expecting an identifier, i.e. signal name}
     end;
    otherwise:  error (2)
   end
  end; {nodeterm}

  procedure setiterm;
   begin
    case palkind of
     p22vx, p16l8,
     p20l10,p20l8 :  iterm := 2;   { all outputs have OE term }
     p16rx:
      case pointer of
        19,12 : if (ptype = '5')or(ptype='6')
                  then iterm := 2  else iterm := 1;
        18,13 : if (ptype = '6') then iterm :=2 else iterm := 1;
        otherwise:  iterm := 1
      end;
     p20rx:
      case pointer of
        22,15 : if (ptype = 'B')or(ptype='C')
                  then iterm := 2  else iterm := 1;
        21,16 : if (ptype = 'C') then iterm :=2 else iterm := 1;
        otherwise:  iterm := 1
      end;
     otherwise: iterm := 1
    end
   end; {setiterm}

  procedure getterms;
   begin
    case palkind of
     p10l8,p12l10:
        totalterms := 2;
     p14l4,p20l10:
        totalterms := 4;
     p12l6:
        if (pointer = 18) or (pointer = 13)
          then totalterms := 4
          else totalterms := 2;
     p14l8:
        if (pointer = 22) or (pointer = 15)
          then totalterms := 4
          else totalterms := 2;
     p16l6:
        if (pointer = 19) or (pointer = 18)
          then totalterms := 2
          else totalterms := 4;
     p18l4:
        if (pointer = 19) or (pointer = 18)
          then totalterms := 4
          else totalterms := 6;
     p22vx:
        case pointer of
         23,14 :  totalterms := 9;
         22,15 :  totalterms := 11;
         21,16 :  totalterms := 13;
         20,17 :  totalterms := 15;
         19,18 :  totalterms := 17;
         otherwise:  writeln ('Software error in procedure getterms!')
        end;
     otherwise:
        totalterms := 8
    end
   end; {getterms}

 procedure map (typ : char);
  var i,j : integer;
  begin {map}
   case typ of
    '0' : {initialize a new output}
        begin
         {first find out if output already has been defined, that is if
           output has an enable previously defined }
         found := false;
writeln ('output : ',token,' nexout=',nexout);
         for i:=1 to nexout do
           with outtable[i] do
            if outname = token
             then begin
                   found := true;     outindex := i
                  end;
         getterms;   {find out how many or-terms this output has }
         setiterm;   {find out where to start orterms }
         if not found
          then begin
                nexout := nexout + 1;
                outtable[nexout].outnumb := pointer; {store output pin number}
                outtable[nexout].outname := token;   {store output name }
                for i:=1 to maxterms do
                 for j:=1 to maxcols do
                  outtable[nexout].matrix[i,j]:= '0';
                outtable[nexout].outkind := nonreg;     {default}
                if iterm > 1 then outtable[nexout].matrix[1,1]:= 'H';
                case ptype of
                 '2' :  outtable[nexout].form := high;
                 otherwise:  outtable[nexout].form := low
                end;
                outindex := nexout
               end
        end
   end
  end; {map}

 procedure orterms;
  begin
   andterm;
   if sym = oroperator
    then begin
          iterm := iterm + 1;
          if iterm > totalterms
           then error (7)
           else orterms
         end
    else begin    {mark termination of equation}
          iterm := iterm + 1;
          outtable[outindex].matrix[iterm,1]:= 'X'
         end
  end; {orterms}

 procedure getmatrix;
  begin {getmatrix}
   case sym of
     enable :
      begin
       gettoken;
       if sym = ident
        then begin
              search (3);  {find out pin number}
              if