⟦6742de8b5⟧

TextFile

;nhp time.300
slet std.conass
beskyt std.conass.61
conass=algol message.no

begin comment constructor for the tda-assembler,
    a call of the constructor has the form:
         resultarea = tac sourcearea
        the data is read from the sourcearea,
        transformed ,checked and written into
        the resultarea.
        the data has the format:
          leading text å
          global variabels å
          format of operations å
          modification tabels å
          data for symboltabels å
          initialization of operationcodetabels å
          ;

integer f,d,addrno,modifno,base,baseindex,length,
          char,name,number,index,i,j,h,k,l,operand,
          c,m,a,o,u,r,ii,e,b,x,comma,point,semicolon,slash,å,em,g,
          wordlength,nooindex,noobase,coresize,charsinword,
          charlength,nooformats,noooperations,maxaddrno,
          maxmodifno,machine,
          nooextra,textword,addressword,realword,charrep,indirect,
          nooperm,expoex,exposh,fracex,fracsh,noocodes;
boolean boo,addror,code,found,basenames,indexnames,permnames,nl,
        list;
long longnumber;
array ar(1:2);
integer array t(1:10);
zone zout(128,1,stderror);

procedure skip(val);
integer val;
begin comment skips chars read from current input
        until a char with internal value val or em
        is met,
        if em is met the program is terminated,
        val=zero means leading spaces and newlines are skipped;
integer i,char;
  if val=0 then
  begin
    for i:=readchar(in,char) while char=32 or char=10 do;
    repeatchar(in)
  end
  else
  for i:=readchar(in,char) while char<>em and char<>val do;
  if char=em then
  begin
    write(out,nl,1,<:***source:>);
    goto errorout
  end
end skip;

boolean procedure readnumber(limit);
integer limit;
begin comment reads in a non-negative integer less then limit
        and stores the value in number,
        the number is preceded by a point,
        if the syntax is incorrect or the value exeedes
        the limit-value readnumber is false else it is true;
integer i,char;
  operand:=operand+1;
  readnumber:=false;
  skip(0); i:=readchar(in,char);
  if char<>point then goto outnum;
  number:=0;
  for i:=readchar(in,char) while i=2 do
  begin
    readnumber:=true;
    number:=number*10+char-48;
    if number>limit then
    begin
      readnumber:=false; goto outnum
    end
  end;
  repeatchar(in);
outnum:
end readnumber;

boolean procedure readbinary(limit);
long limit;
begin comment reads integers in binary form,
        syntax as readnumber,
        returns value in longnumber;
integer i,char;
  operand:=operand+1;
  readbinary:=false;
  skip(0); i:=readchar(in,char);
  if char<>point then goto outbin;
  longnumber:=0;
  for i:=readchar(in,char) while char=48 or char=49 do
  begin
    readbinary:=true;
    longnumber:=longnumber*2+char-48;
    if longnumber>limit then
    begin
      readbinary:=false; goto outbin
    end
  end;
outbin:
  repeatchar(in)
end readbinary;

boolean procedure readname;
begin comment reads in a name,only the 4 first chars.
        the value is returned in name.
        if the first char is not a letter eadname is false;
integer i,j,val,char;
  skip(0);
  operand:=operand+1;
  name:=j:=0; readname:=false;
  for i:=readchar(in,char) 
    while (i=6 or (i=2 and j>0)) and j<4 do
  begin
    j:=j+1; readname:=true; 
    name:=name*40+(if i=6 then char-86 else char-48)
  end;
  repeatchar(in);
  if j=4 then
  for i:=readchar(in,char) while i=6 or i=2 do;
  repeatchar(in)
end readname;

procedure error(no,destination,val);
integer no,val; label destination;
begin comment writes an errormessage,skips tomval and
        continues from destination;
integer i,char;
  write(out,nl,2,<:***:>,<<-ddd>,case no of
        (<:length:>,<:format:>,<:modification:>,
        <:mask:>,<:symboltabel:>,<:opcodetabel:>,
        <:resultarea:>,<:opcodetabelsize:>,<:textrep:>));
  if no<7 then write(out,if no<5 then f else index);
  if no=8 then write(out,noocodes);
  if no<>7 or j<>1 then write(out,operand);
  skip(val);
  write(out,nl,2);
  goto destination
end error;

procedure writename(name);
integer name;
begin comment writes out a name;
integer i,char,val;
boolean array r(1:4);
  val:=name;
  for i:=1,2,3,4 do r(i):=false add 32;
  i:=5;
  for i:=i-1 while i>0 and val<>0 do
  begin
    char:=val mod 40;
    r(i):=if char<11 then false add (char+47)
          else false add (char+86);
    val:=val//40
  end;
  for i:=1,2,3,4 do write(out,r(i),1)
end writename;

  nl:=false add 10;
  em:=25;
  å:=125;
  
comment skip leading text;

  skip(å);

comment read in global variabels;

  read(in,machine,wordlength,nooindex,noobase,coresize,
      nooformats,noooperations,maxaddrno,maxmodifno,
      nooextra,nooperm,
      charrep,
      realword,expoex,exposh,fracex,fracsh,
      addressword,indirect,
      noocodes);

comment initialize variabels and constants;

   skip(å);
  a:=97;
  b:=98;
  c:=99;
  e:=101;
  ii:=105;
  m:=109;
  o:=111;
  r:=114;
  u:=117;
  x:=120;
  comma:=44;
  point:=46;
  semicolon:=59;
  slash:=47;
  baseindex:=0;
  basenames:=noobase>0;
  if -,basenames then noobase:=1;
  indexnames:=nooindex>0;
  if -,indexnames then nooindex:=1;
  permnames:=nooperm>0;
  if -,permnames then nooperm:=1;

comment test size of opcodetabels;

  if noocodes mod 2=0 or
     noocodes mod 37=0 or
     noocodes<50 then error(8,errorout,0);

comment initialize resultarea;

  if readparam(ar)>=0 then error(7,errorout,0);
  i:=1;
  open(zout,0,string ar(increase(i)),0);
  if monitor(42,zout,0,t)<>0 or t(9)<>0 then
    error(7,errorout,0);
  j:=t(1);
  if j>0 then j:=4 else
  begin
    j:=(j shift 1) shift (-1);
    for i:=1,2 do ar(i):=
      0.0 shift 24 add t(i*2) shift 24 add t(i*2+1)
  end;
  close(zout,true);
  i:=1;
  open(zout,4,string ar(increase(i)),0);

comment read list option;

  list:=false;
  readparam(ar);
  readparam(ar);
  if readparam(ar)=2 then
  begin
    if ar(1)=real<:list:> then
    begin
    readparam(ar);
    list:=ar(1)=real<:yes:>
    end
  end;

comment calculate the textrepresentation;

  charlength:=if charrep=2 then 6 else 8;
  j:=0;
  for j:=j+1 while (wordlength*j) mod charlength<>0 do;
  if wordlength*j<=48 then
  begin
    charsinword:=wordlength*j//charlength;
    textword:=j
  end
  else error(9,errorout,0);

comment tabels describing the operations are declared;

  begin
  boolean array opf,maskaddr,bi,formattab(0:nooformats-1),
          amf,adf(0:nooformats-1,0:maxaddrno),
        adrmodif(0:(nooformats)*(noobase+nooindex+4));
  integer array indextab(1:nooindex),
        basetab(1:noobase),
        permtab(1:nooperm*2),
        opcodename,opcode(0:noocodes),
        symname(1:noobase+nooindex+nooperm+10);
  long array maskvalue(0:nooformats-1);

  procedure inoptab(name,index,found);
value name;
  integer name,index;
  boolean found;
  begin integer k;
        comment inserts the name in the opcodetabels,
          found tells if the name was in the tabel,
          index gives the index of the last entry examined;
   k:=(name shift (-12) + name extract 12) mod noocodes;
   for index:=k+1 step 1 until noocodes,
              0 step 1 until k do
   if opcodename(index)=name then
   begin found:=true; goto OUT; end else
   if opcodename(index)=0 then
   begin found:=false; opcodename(index):=name; goto OUT; end;
OUT:
  end inoptab;

  boolean procedure compare;
  begin comment compares a name with a list of names,
        if the name is found compare is false else
        the name is added to the list and compare is true;
  integer i;
    i:=0;
    for i:=i+1 while symname(i)<>0 and symname(i)<>name do;
    compare:=symname(i)=0;
    symname(i):=name;
  end compare;

  procedure loopend(no,dest,val,sep,limit);
  integer no,val,sep,limit;
  label dest;
  begin comment tests end of a loop;
    skip(0); g:=readchar(in,char);
    if char=sep or j=limit then
    begin
      if char<>sep or j<>limit then
      begin
        repeatchar(in); error(no,dest,val)
      end
    end
  end loopend;

    for i:=0 step 1 until nooformats-1 do
    begin
      opf(i):=maskaddr(i):=formattab(i):=
      bi(i):=false add 0;
      maskvalue(i):=0;
      for j:=1 step 1 until maxaddrno do
      adf(i,j):=amf(i,j):=false add 0
    end;
    for i:=0 step 1 until (nooformats)*(noobase+nooindex+4) do
      adrmodif(i):=false add 0;
    for i:=0 step 1 until noocodes do
      opcode(i):=opcodename(i):=0;
    for i:=1 step 1 until nooindex do
      indextab(i):=0;
    for i:=1 step 1 until noobase do
      basetab(i):=0;
    for i:=1 step 1 until nooperm*2 do
      permtab(i):=0;
    for i:=1 step 1 until noobase+nooindex+nooperm+10 do
      symname(i):=0;

comment the formats of the operations are read in,
        a format has the form:
        no of words semicolon
        layout semicolon
        modification semicolon
        mask/
        the layout consists of statements: code.field length
        separated by commas.
        the layoutcodes are
          c            code field (only one)
          a            address field
          m            addr modif field
          o            masked addr field (only one)
          u            unused
        the modification consists of statements: code.modifvalue
        separated by commas.
        the modification values are:
          r            relative addressing
          i            indirect
          m            immediate
          e            extended
          b            baseregisterrelative
          x            indexed
        the b-code demands noobase modifvalues,
        the x-code demands nooindex modifvalues
        the mask consists of m.value
        ;

    for f:=0 step 1 until nooformats-1 do
    begin
    comment initialize formatstatement;
      operand:=0;
      code:=addror:=false;
      addrno:=modifno:=0;
      d:=48;
      base:=f*(4+noobase+nooindex);
      for h:=0 step 1 until noobase+nooindex+3 do
      adrmodif(base+h):=false add 128;
      maskaddr(f):=false add 0;

comment read number of words;

      read(in,length);
      if length*wordlength>48 then error(1,nextformat,slash);
      repeatchar(in);
      skip(0); g:=readchar(in,char);
      if char<>semicolon then error(1,nextformat,slash);

comment read format of machine word(s);

formatpart:
      skip(0); g:=readchar(in,name);
      operand:=operand+1;
      if -,readnumber(48) then error(2,nextformat,slash);
      if name=c then
      begin comment code field;
        if code then error(2,nextformat,slash);
        code:=true;
        d:=d-number;
        opf(f):=false add d shift 6 add number
      end
      else if name=m then
      begin comment modification part;
        modifno:=modifno+1;
        if modifno>maxmodifno then error(2,nextformat,slash);
        d:=d-number;
        amf(f,modifno):=false add d shift 6 add number
      end
      else if name = a then
      begin comment address part;
        addrno:=addrno+1;
        if addrno>maxaddrno then error(2,nextformat,slash);
        d:=d-number;
        adf(f,addrno):=false add d shift 6 add number
      end
      else if name=o then
      begin comment address part to be masked;
        if addror then error(2,nextformat,slash);
        addror:=true;
        addrno:=addrno+1;
        if addrno>maxaddrno then error(2,nextformat,slash);
        adf(f,addrno):=false add d shift 6 add number;
        maskaddr(f):=false add (addrno)
      end
      else if name=u then
      begin comment undefined part;
        d:=d-number
      end
      else error(2,nextformat,slash);
      skip(0); g:=readchar(in,char);
      if char=comma then goto formatpart else
      if char<>semicolon then error(2,nextformat,slash);

comment test length of formatdescription;

      if 48-d<>length*wordlength then error(2,nextformat,slash);
      formattab(f):=false add length shift 4
          add addrno shift 4 add modifno;

comment read in addressmodification symbols;

modifpart:
      operand:=operand+1;
      skip(0); g:=readchar(in,name);
      if name=semicolon then goto maskpart;
      index:= if name=r then 0 else
              if name=ii then 1 else
              if name=e then 2 else
              if name=m then 3 else -1;
      if index<>-1 then
      begin
        if adrmodif(base+index) extract 12<>128
        and -,readnumber(48)
        then error(3,nextformat,slash);
        adrmodif(base+index):=false add number
      end
      else if name=b then
      begin
      for h:=1 step 1 until noobase do
      begin
        if adrmodif(base+3+h) extract 12 <>128 
        and -,readnumber(48) then
        error(3,nextformat,slash);
        adrmodif(base+3+h):=false add number
      end
      end
      else if name=x then
      begin
        for h:=1 step 1 until nooindex do
        begin
          if adrmodif(base+3+noobase+h) extract 12<>128 
          and -,readnumber(48) then
          error(3,nextformat,slash);
          adrmodif(base+3+noobase+h):=false add number
        end
      end
      else error(3,nextformat,slash);
      skip(0); g:=readchar(in,char);
      if char=comma then goto modifpart else
      if char<>semicolon then error(3,nextformat,slash);

comment read in mask part;

maskpart:
      skip(0); g:=readchar(in,char);
      operand:=operand+1;
      if (addror and char<>m) or ( -,addror and char<>slash)
        then error(4,nextformat,slash);
      if addror then
      begin
      if readbinary(long(2**24-1)) then maskvalue(f):=longnumber
      else error(4,nextformat,slash);
      end else repeatchar(in);
      skip(slash);

comment calculate base for modif 2 action;

nextformat:
      bi(f):=false add baseindex;
      baseindex:=baseindex+2**(amf(f,1) extract 6)*addrno;

comment test end of statement;

      skip(0); g:=readchar(in,char); repeatchar(in);
      if char=å or f=nooformats-1 then
      begin
      if char<>å or f<>nooformats-1 then
      error(4,modiftabels,å)
      end
    end format loop;
comment modify base for modif action;

    baseindex:=baseindex-1;

    skip(å);

modiftabels:;
comment tabel for symbols,operationcodes and addresscal-
        culation are declared;

    begin
    boolean array modif1tab(0:nooformats-1),
        modif2tab(0:baseindex);
    integer array aid1(0:nooformats-1),
        aid2(0:baseindex);

      for i:=0 step 1 until nooformats-1 do aid1(i):=0;
      for i:=0 step 1 until baseindex do aid2(i):=0;

comment data for the modificationtabels are read in,
        the data has the form:
          data for modif1tab/data for modif2tab/
        ;
      read(in,aid1,aid2);
      repeatchar(in); skip(å);
      for j:=0 step 1 until nooformats-1 do
      modif1tab(j):=false add aid1(j);
      for j:=0 step 1 until baseindex do
      modif2tab(j):=false add aid2(j);

symboltab:;
comment data for the symboltabels are read in,
        it has the form:
          indexregister names/
          baseregister names/
          permanent names/
        a permanent name has the form:
          name.value
        ;

      operand:=0;

comment indexregister names;

      if indexnames then
      begin
      for j:=1 step 1 until nooindex do
      begin
        if readname and compare then indextab(j):=name
        else error(5,opcodetabels,å);
        loopend(5,opcodetabels,å,slash,nooindex)
      end
      end else skip(slash);

comment baseregister names;

      if basenames then
      begin
      for j:=1 step 1 until noobase do
      begin
        if readname and compare then basetab(j):=name
        else error(5,opcodetabels,å);
        loopend(5,opcodetabels,å,slash,noobase)
      end
      end else skip(slash);
comment permanent names;

      if permnames then
      begin
      for j:=1 step 1 until nooperm do
      begin
        if readname and compare and readnumber(8388606) then
        begin
          permtab(j*2-1):=name;
          permtab(j*2):=number;
        end;
        loopend(5,opcodetabels,å,slash,nooperm)
      end
      end else skip(slash);
      skip(å);

opcodetabels:;
comment read in data for the opcodetabels,
        the data has the form:
          extradirectives/operationcodes/
        extradirectives consists of a
          name.actionno+31.no of words generated
                        .state1.state2
        operationcodes consists of a
          name.formatno.machinecode
        ;
comment put directives in:r,c,z,l,u,n,t,m;

      i:=0;
      for j:=28,13,36,22,31,24,30,23 do
      begin
        i:=i+1;
        inoptab(j,index,found);
        opcode(index):=case i of
            (9shift 6 add 9 shift 12 add 36,
            0 shift 6 add 9 shift 12 add 37,
            0 shift 6 add 8 shift 12 add 38,
            0 shift 6 add 9 shift 12 add 39,
            0 shift 6 add 8 shift 12 add 40,
            0 shift 6 add 8 shift 12 add 41,
            0 shift 6 add 8 shift 12 add 42,
            0 shift 6 add 9 shift 12 add 44)
      end;

comment put extra directives in;
      operand:=0;

      if nooextra>0 then
      begin
      for j:=1 step 1 until nooextra do
      begin
        found:=true;
        if readname then inoptab(name,index,found);
        boo:= -,readnumber(64); h:=number;
        boo:=boo or -,readnumber(64); k:=number;
        boo:=boo or -,readnumber(64); l:=number;
        if boo or -,readnumber(64) or found then
        error(6,codenames,slash) else
        opcode(index):=number shift 6 add l shift 6 add k
          shift 6 add h;
        loopend(6,outprogram,å,slash,nooextra)
      end
      end else skip(slash);

codenames:;
comment put operationcodes in;

      for j:=1 step 1 until noooperations do
      begin
        found:=true;
        if readname then inoptab(name,index,found);
        boo:= -,readnumber(nooformats-1); h:=number;
        boo:=boo or -,readbinary(long(2**(opf(h)extract 6)));
        if -,found or -,boo then
        opcode(index):=longnumber shift 6 add h
        else error(6,outprogram,0);
        if boo or found then error(6,outprogram,0);
        loopend(6,outprogram,å,slash,noooperations)
      end;

outprogram:;
comment the tabels are written on current output for control;

      if -,basenames then noobase:=0;
      if -,indexnames then nooindex:=0;
      if -,permnames then nooperm:=0;

      if -,list then goto nolist;
      write(out,false add 12,1,<:global variabels::>,nl,2);
      write(out,<<-dddddd>,
      <:machine                       ::>,
      (case machine of (<:  TEXAS 980 A:>,<:  INTEL 8008:>,
                        <:  INTEL 8080:>,<:  VARIAN 620/i:>,
                        <:  PDP 8:>,<:  MOTOROLA M6800:>)),nl,1,
      <:no of operations              ::>,noooperations,nl,1,
      <:no of indexregisters          ::>,nooindex,nl,1,
      <:no of baseregisters           ::>,noobase,nl,1,
      <:coresize                      ::>,coresize,nl,1,
      <:wordlength                    ::>,wordlength,nl,1,
      <:textpart in words             ::>,textword,nl,1,
      <:charecterrepresentation       ::>,
      (case charrep+1 of(<:  iso 8-bit:>,<:  ascii 8-bit:>,
                         <:  ascii 6-bit:>)),nl,1,
      <:no of charecters in textpart  ::>,charsinword,nl,1,
      <:realnumber in words           ::>,realword,nl,1,
      <:realnumber format (ex,frac)   ::>,<<-dd>,
      expoex,exposh,fracex,fracsh,nl,1,<<-dddddd>,
      <:addressword in words          ::>,addressword,nl,1,
      <:indirect correction           ::>,indirect,
      false add 12,1);

      write(out,nl,3,<:formats::>,nl,2);
      for i:=0 step 1 until nooformats-1 do
      begin
        write(out,<<-dd>,<:no::>,i,nl,1,<:layout        ::>,
            opf(i) extract 6,
            opf(i) shift(-6) extract 6);
        for j:=1 step 1 until maxaddrno do
        write(out,<<-dd>,amf(i,j) extract 6,
                         amf(i,j) shift (-6) extract 6,
                         adf(i,j) extract 6,
                         adf(i,j) shift (-6) extract 6);
        write(out,<<-ddd>,nl,1,<:maskaddr/value::>,
                  maskaddr(i) extract 12,
                  maskvalue(i),nl,1,
        <:modifications ::>);
        h:=bi(i) extract 12;
        l:=if i<nooformats-1 then bi(i+1) extract 12
           else baseindex+1;
        for j:=0 step 1 until noobase+nooindex+3 do
        write(out,<<-ddd>,
              adrmodif(i*(noobase+nooindex+4)+j) extract 12);
        write(out,nl,1,<:addr actions  ::>,<<-ddd>,
          modif1tab(i) extract 12,nl,1,false add 32,15,h,<:::>);
        j:=h-1;
        for j:=j+1 while j<l do
        write(out,<<-dd>,modif2tab(j) extract 12);
        write(out,nl,3)
      end;
      write(out,nl,3,<:symbols::>,nl,2);
      i:=0; for i:=i+1 while i<=nooindex do
      begin
        writename(indextab(i)); write(out,<:    indexreg:>,nl,1)
      end;
      i:=0; for i:=i+1 while i<=noobase do
      begin
        writename(basetab(i)); write(out,<:    basereg:>,nl,1)
      end;
      i:=0; for i:=i+1 while i<=nooperm do
      begin
        writename(permtab(i*2-1));
        write(out,<<-dddddd>,permtab(i*2),nl,1)
      end;

      write(out,false add 12,1,<:operation tabels::>,nl,1);
      for i:=0 step 1 until noocodes do
      begin
        write(out,<<-ddd>,nl,1,i,false add 32,3);
        writename(opcodename(i));
        write(out,<<-ddddddd>,
            opcode(i),opcode(i) extract 6);
        if opcode(i) extract 6>nooformats then
        write(out,<<-dddddd>,
              opcode(i) shift(-6) extract 6,
              opcode(i) shift(-12) extract 6,
              opcode(i) shift(-18) extract 6)
        else write(out,<<-dddddd>,
              opcode(i) shift(-6) extract 18);
      end;
nolist:;

comment write variabels and tabels to initialize the
        assembler into the resultarea;

      write(zout,machine,wordlength,nooindex,noobase,coresize,
            nooformats,textword,charrep,charsinword,charlength,
            realword,expoex,exposh,fracex,fracsh,
            addressword,indirect,noocodes,nooperm,
            baseindex,maxaddrno);
      for i:=0 step 1 until noocodes do
      write(zout,opcodename(i));
      for i:=0 step 1 until noocodes do
      write(zout,opcode(i));
      if indexnames then
      for i:=1 step 1 until nooindex do
      write(zout,indextab(i));
      if basenames then
      for i:=1 step 1 until noobase do
      write(zout,basetab(i));
      if permnames then
      for i:=1 step 1 until nooperm*2 do
      write(zout,permtab(i));
      for i:=1 step 1 until nooformats do
      write(zout,formattab(i-1) extract 12);
      for i:=1 step 1 until nooformats do
      write(zout,opf(i-1) extract 12);
      for i:=1 step 1 until nooformats do
      write(zout,modif1tab(i-1) extract 12);
      for i:=0 step 1 until (nooformats)*(noobase+nooindex
                       +4) do
      write(zout,adrmodif(i) extract 12);
      for i:=0 step 1 until baseindex do
      write(zout,modif2tab(i) extract 12);
      for i:=0 step 1 until nooformats-1 do
      write(zout,bi(i) extract 12);
      for i:=0 step 1 until nooformats-1 do
      for j:=0 step 1 until maxaddrno do
      write(zout,amf(i,j) extract 12);
      for i:=0 step 1 until nooformats-1 do
      for j:=0 step 1 until maxaddrno do
      write(zout,adf(i,j) extract 12);
      for i:=0 step 1 until nooformats -1 do
      write(zout,maskaddr(i) extract 12);
      for i:=0 step 1 until nooformats-1 do
      write(zout,maskvalue(i));
      write(zout,0,0)
    end
  end;
errorout:
  close (zout,true)
end
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦6742de8b5⟧ TextFile

Derivation

TextFile
