ADA Programming Guide/ADA Programming Guide.iso/ada_pcdp/adas/compile.pas

Pascal/Delphi Source File | 1996-01-30 | 11.3 KB | 449 lines

unit compile;

  { Main program for compiler }

interface
uses global, util, state;
procedure compiler(var result: boolean);

implementation

procedure block(level: integer);

  { Compile a block -
     all routines except initialization are local to block }
type
  conrec =    { constant record }
    record
      tp: types;   { constant type }
      i:  integer  { constant value }
    end;

var dx:  integer;  { counter for stack memory requirements }
    prt: integer;  { symbol table pointer for this block }
    prb: integer;  { block table pointer for this block }

procedure constant(var c: conrec);
  { Constant declaration:
      character or integer constants,
      also equate one constant to another.
    Called from variable declaration in Ada }
var x, sign: integer;
begin
  c.tp := notyp;
  c.i := 0;
  if sy in constbegsys then
    if sy = charcon then
      begin
      c.tp := chars;
      c.i := inum;
      insymbol
      end
    else begin
      sign := 1;
      if sy in [plus, minus] then
        begin
        if sy = minus then sign := -1;
        insymbol
        end;
      if sy = ident then
        begin
        x := loc(level, id);
        if x = 0 then error(ernf);
        if tab[x].obj <> konstant then error(ertyp);
        c.tp := tab[x].typ;
        c.i := sign * tab[x].adr;
        insymbol
        end
      else if sy = intcon then
        begin
        c.tp := ints;
        c.i := sign * inum;
        insymbol
        end
      else error(erkey)
      end
end;

procedure typ(var tp: types; var rf, sz: integer);
  { Compilation of "subtype indication":
      Only allowed to equate to an existing type and
      to define a one dimensional array}
var x: integer;
    eltp: types;
    elrf: integer;
    elsz, offset, t0, t1: integer;

  procedure arraytyp(var aref, arsz: integer);
  var eltp: types;
      low, high: conrec;
      elrf, elsz: integer;
  begin
    constant(low);
    if sy = colon then insymbol else error(erpun);
    constant(high);
    if high.tp <> low.tp then error(ertyp);
    enterarray(low.tp, low.i, high.i);
    aref := a;
    if sy = rparent then insymbol else error(erpun);
    if sy = ofsy then insymbol else error(erkey);
    typ(eltp, elrf, elsz);
    with atab[aref] do
      begin
      arsz := (high-low+1) * elsz;
      size := arsz;
      eltyp := eltp;
      elsize := elsz
      end
  end;

begin (* typ *)
  tp := notyp;
  rf := 0;
  sz := 0;
  if sy in typebegsys then
    if sy = ident then
      begin
      x := loc(level, id);
      if x = 0 then error(ernf);
      with tab[x] do begin
        if obj <> type1 then error(ertyp);
        tp := typ;
        rf := ref;
        sz := adr;
        if tp = notyp then error(ertyp)
        end;
      insymbol
      end
    else if sy = arraysy then
      begin
      insymbol;
      if sy = lparent then insymbol else error(erpun);
      tp := arrays;
      arraytyp(rf, sz)
      end
    else error(erkey)
end;

procedure parameterlist;
  { Parameter list declarations:
       in parameter like Pascal value copy semantics
       out and in out parameter like Pascal var reference semantics }
var tp: types;
    rf, x, t0: integer;
    valpar: boolean;
begin
  insymbol;
  tp := notyp;
  rf := 0;
  while sy = ident do
    begin
    valpar := true;
    t0 := t;
    repeat
      enter(id, variable, level);
      insymbol;
      if sy = comma then insymbol
    until sy <> ident;
    if sy = colon then insymbol else error(erpun);
    if sy = insy then insymbol;
    if sy = outsy then
      begin valpar := false; insymbol end;
    if sy <> ident then error(erid);
    x := loc(level, id);
    insymbol;
    if x = 0 then error(ernf);
    with tab[x] do begin
      if obj <> type1 then error(ertyp);
      tp := typ;
      rf := ref;
      if valpar and (typ=arrays) then error(ertyp)
      end;
    while t0 < t do
      begin
      t0 := t0 + 1;
      with tab[t0] do
        begin
        typ := tp;
        ref := rf;
        normal := valpar;
        adr := dx;
        lev := level;
        dx := dx + 1
        end
      end;
    if sy <> rparent then
      if sy = semicolon then insymbol else error(erpun);
    end (* while *);
  if sy = rparent then insymbol else error(erpun)
end;

procedure typedeclaration;
var tp: types;
    rf, sz, t1: integer;
begin
  insymbol;
  enter(id, type1, level);
  t1 := t;
  insymbol;
  if sy = issy then insymbol else error(erpun);
  typ(tp, rf, sz);
  with tab[t1] do
    begin
    typ := tp;
    ref := rf;
    adr := sz
    end;
  if sy = semicolon then insymbol else error(erpun)
end;

procedure variabledeclaration;
  { Variable declaration:
      includes Ada constant declarations,
      initial values are noted in a special table which
        causes code to be emitted upon entry to the program }
var t0, t1, rf, sz: integer;
    tp: types;
    c: conrec;
    cflag, initflag: boolean;
begin
  while sy = ident do
    begin
    cflag := false;
    initflag := false;
    t0 := t;
    repeat
      enter(id, variable, level);
      insymbol;
      if sy = comma then insymbol
    until sy <> ident;
    if sy = colon then insymbol else error(erpun);
    if sy = constsy then   { note that this is a constant }
      begin
      insymbol;
      cflag := true
      end;
    t1 := t;
    if sy = becomes then tp := ints
    else typ(tp, rf, sz);
    if sy = becomes then  { either initial value or constant }
      begin
      insymbol;
      if (sy = ident) and (id = 'init      ') then
        begin  { special form for semaphore initialization }
        insymbol;
        if sy = lparent then insymbol else error(erpun);
        constant(c);
        if sy = rparent then insymbol else error(erpun)
        end
      else constant(c);
      initflag := true;
      if c.tp <> tp then error(ertyp)
      end;
    while t0 < t1 do
      begin
      t0 := t0 + 1;
      with tab[t0] do
        if cflag then  { constant must be initialized }
          if not initflag then error(erkey)
          else begin
            typ := c.tp;
            adr := c.i;
            ref := 0;
            obj := konstant
          end
      else begin
        typ := tp;
        ref := rf;
        lev := level;
        adr := dx;
        normal := true;
        dx := dx + sz;
        if initflag then  { store info on initialization }
          begin
          if c.tp <> typ then error(ertyp);
          inits := inits + 1;
          inittab[inits].addr := adr;
          inittab[inits].value := c.i
          end
        end
    end;
    if sy = semicolon then insymbol else error(erpun)
    end
end;

procedure procdeclaration;
  { Procedure declaration - also used for tasks }
var istask: boolean;
    id1: alfa;
begin
  istask := sy = tasksy;
  if sy = tasksy then  { ignore task specification !! }
    repeat insymbol until sy = bodysy;
  insymbol;
  if sy <> ident then error(erid);
  id1 := id;   { save name to check at end }
  if istask then enter(id, task, level)
            else enter(id, prozedure, level);
  if istask then curtask := t;
  tab[t].normal := true;
  if istask then  { tasks must be elaborated }
    begin
    elabs := elabs + 1;
    elabtab[elabs] := loc(level, id)
    end;
  insymbol;
  block(level+1);
  if sy = ident then
    begin
    if id <> id1 then error(erkey);
    insymbol
    end;
  if sy = semicolon then insymbol else error(erpun);
  emit(32)  (* exit *)
end;

procedure initouterblock;
  { Outermost block emits code for initializing global variables
      and elaborating tasks }
var x: integer;
begin
  for x := 1 to inits do
    begin
    emit2(0,1,inittab[x].addr);  { load variable address }
    emit1(24,inittab[x].value);  { load initial value }
    emit1(38,0)                  { store }
    end;
  if elabs <> 0 then
    begin
    emit(4);                     { cobegin from Pascal-S }
    for x := 1 to elabs do
      begin
      emit1(18, elabtab[x]);     { markstack and call task }
      emit1(19, btab[tab[elabtab[x]].ref].psize-1)
      end;
    emit(5)                      { coend from Pascal-S }
    end
end;

begin (* block *)
  dx := 5;
  prt := t;
  if level > lmax then fatal(5);
  enterblock;
  display[level] := b;
  prb := b;
  tab[prt].typ := notyp;
  tab[prt].ref := prb;
  if (sy = lparent) and (level > 1) then parameterlist;
  btab[prb].lastpar := t;
  btab[prb].psize := dx;
  if sy = issy then insymbol else error(erpun);
  repeat     { no predefined order in Ada }
    if sy = typesy then typedeclaration;
    if sy in [proceduresy, tasksy] then procdeclaration;
    if sy <> beginsy then variabledeclaration;
    if sy = pragmasy then  { ignore pragmas }
      begin
      repeat insymbol until sy = semicolon;
      insymbol
      end;
  until sy = beginsy;  { terminate upon begin of statement part }
  btab[prb].vsize := dx;
  tab[prt].adr := lc;
  if level = 1 then initouterblock;
  insymbol;
  statement(dx, level);
  while sy in [semicolon] + statbegsys do
    statement(dx, level);
  if sy = endsy then insymbol else error(erkey);
  btab[prb].vsize := dx;
end;

procedure initentries;
  { predefined symbol table entries }
begin
  enterst('          ', variable, notyp, 0); (* sentinel *)
  enterst('false     ', konstant, bools, 0);
  enterst('true      ', konstant, bools, 1);
  enterst('character ', type1,    chars, 1);
  enterst('boolean   ', type1,    bools, 1);
  enterst('integer   ', type1,    ints,  1);
  enterst('semaphore ', type1,    ints,  1);

  enterst('get       ', prozedure,notyp,  1);
  enterst('skip_line ', prozedure,notyp,  2);
  enterst('put       ', prozedure,notyp,  3);
  enterst('new_line  ', prozedure,notyp,  4);
  enterst('put_line  ', prozedure,notyp,  4);
  enterst('wait      ', prozedure,notyp,  5);
  enterst('signal    ', prozedure,notyp,  6);
  enterst('          ', prozedure,notyp,  0);
end;

procedure initcompiler;
begin
  inits := 0;
  elabs := 0;
  t := -1;
  a := 0;
  b := 1;
  display[0] := 1;
  with btab[1] do
    begin
    lastpar := 1;
    psize := 0;
    vsize := 0
    end;
  entries := 0;
  initutil;
end;

procedure compiler(var result: boolean);
  { Prompt for file name and then call compiler }
var ok: boolean;
    ch: char;
    progname: alfa;
begin
  write('Listing (y/n) ');
  readln(ch);
  listing := ch = 'y';
{$I-}
  assign(inp, inputfile+'.ada');
  ok := ioresult = 0;
  reset(inp);
  ok := ok and (ioresult = 0);
  if listing then
    begin
    assign(list, inputfile+'.lis');
    ok := ioresult = 0;
    rewrite(list);
    ok := ok and (ioresult = 0);
    end;
{$I+}
  if not ok then writeln('Can''t open') else
    begin
    initcompiler;
    insymbol;
    while sy <> proceduresy do insymbol;
    insymbol;
    if sy <> ident then error(erid);
    progname := id;
    insymbol;

    initentries;
    btab[1].last := t;
    block(1);
    if (sy = ident) and (id = progname) then insymbol;
    if sy <> semicolon then error(erpun);
    if btab[2].vsize > stmax-stkincr*pmax then error(erln);
    emit(31); (* halt *)
    if not eof(inp) then readln(inp);
    if listing then close(list);
    writeln('Compilation OK')
    end;
    result := ok
end;

end.