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


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

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

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

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

54.1
date     91.03.18.15.36.56;  author jwh;  state Exp;
branches ;
next     53.1;

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

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

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

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

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

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

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

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

45.1
date     90.04.19.16.05.44;  author jwh;  state Exp;
branches ;
next     44.1;

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

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

42.1
date     90.01.23.17.59.37;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.41.25;  author jwh;  state Exp;
branches ;
next     40.2;

40.2
date     89.12.19.09.36.33;  author dew;  state Exp;
branches ;
next     40.1;

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

39.1
date     89.09.26.16.47.27;  author dew;  state Exp;
branches ;
next     1.2;

1.2
date     89.09.15.10.02.55;  author dew;  state Exp;
branches ;
next     1.1;

1.1
date     89.09.14.11.23.31;  author dew;  state Exp;
branches ;
next     ;


desc
@MAKER is version 4 of the State Table Generator created by
Robert Quist.
@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@$MODCAL$
$DEBUG ON$
PROGRAM MACHINE_MAKER(INPUT,OUTPUT);
{local search{{
$SEARCH 'MATCHSTR'$
{system search{}
$SEARCH 'PROGS:MATCHSTR'$
{}

IMPORT SYSGLOBALS,MATCHSTR;
CONST
  version = 'machine maker version 4.0';
  max_name_size = 16;
TYPE
  name_type = string[max_name_size];
  proc_name_type = string80;
  pnamep = ^proc_name_type;
  ref_list_recp = ^ref_list_rec;
  ref_list_rec = record
		   pname: pnamep;
		   next : ref_list_recp;
		 end;
  proc_recp = ^proc_rec;
  proc_rec  = record
	       pname : proc_name_type;
	       next  : proc_recp;
	      end;
  exit_class_type = (singles,singles_catch,pairs,pairs_catch);
  exit_recp = ^exit_rec;
  exit_rec = record
	       event : name_type;
	       ename : name_type;
	       next  : exit_recp;
	     end;
  state_class_type = (standard,mcall,mexit,suspend,done_exit);
  state_recp = ^state_rec;
  state_rec = record
		name    : name_type;
		state_class : state_class_type;
		nprocs : integer;
		procs_list : proc_recp;
		exit_class : exit_class_type;
		nexits : integer;
		exit_list : exit_recp;
		next : state_recp;
	      end;
  option_type = (none,module_name,
		 event_singles,event_singles_catch,
		 event_pairs,event_pairs_catch,
		 machine_name,global_recover,end_machine);
VAR
  sname,
  modname : string255;
  sfile,
  mfile : text;
  sline : string255;
  all_done : boolean;
  ecode : integer;
  {-----------------------}
  mod_name    : string80;
  m_name      : string80; { machine_name }
  g_recover   : name_type;
  state_list,
  last_state,
  current_state : state_recp;
  ref_list      : ref_list_recp;
  refs_on       : boolean;
  current_option: option_type;

  procedure error(n:integer);
    var x : integer;
    var es1 : string[80];
    begin
      es1 := '';
      case n of
     -1: es1 := 'empty file';
      0: es1 := 'unexpected EOF';
      1: es1 := 'invalid state definition';
      2: es1 := 'invalid state name';
      3: es1 := 'duplicate state definition'+current_state^.name;;
      4: es1 := 'require only one exit code for state '+current_state^.name;
      5: es1 := 'invalid state class : '+sline;
      6: es1 := 'require only one state reference for state '+current_state^.name;
      7: es1 := 'require only one machine reference for state '+current_state^.name;
      8: es1 := 'invalid option : '+sline;
      9: es1 := 'global recover state '+g_recover+' not defined ';
     10: strwrite(es1,1,x,'invalid exit class : ',current_option,
			  ' for state ',current_state^.name);
      otherwise
	strwrite(es1,1,x,'Error ',n:1);
      end; { case }
      writeln(mfile,'->->',es1);
      escape(0);
    end;

  procedure upper_case(var s:string);
    var i : integer;
    begin
      for i := 1 to strlen(s) do
	if s[i] in ['a'..'z'] then s[i] := chr(ord(s[i])-ord('a')+ord('A'));
    end; { upper_case }

  function get_sline:boolean;
    var
      done : boolean;
      i,j  : integer;
    begin
      done := false;
      while not done do
      begin
	current_option := none;
	if eof(sfile) then error(0);
	readln(sfile,sline);
	sline := strrtrim(sline);
	writeln(mfile,sline);
	if sline<>'' then
	if sline[1]='*' then
	begin
	  strdelete(sline,1,1);
	  upper_case(sline);
	  if strlen(sline)>1 then
	    if sline[1]='$' then
	    begin i := 2;
	      try
		strread(sline,i,i,current_option);
	      recover
		error(8);
	      case current_option of
	      module_name:
		begin
		  i := spanstr(sline,i,' ');
		  j := breakstr(sline,i,' ');
		  if j = 0 then j := strlen(sline)+1;
		  mod_name := str(sline,i,j-i);
		end;
	      machine_name:
		begin
		  i := spanstr(sline,i,' ');
		  j := breakstr(sline,i,' ');
		  if j = 0 then j := strlen(sline)+1;
		  m_name := str(sline,i,j-i);
		  done := true;
		end;
	      global_recover:
		begin
		  i := spanstr(sline,i,' ');
		  j := breakstr(sline,i,' ');
		  if j = 0 then j := strlen(sline)+1;
		  g_recover := str(sline,i,j-i);
		  done := true;
		end;
	      end_machine:
		begin
		  all_done := true; done := true;
		end;
	      otherwise
		done := true;
	      end; {case option}
	    end
	    else
	    if sline[1]<>'*' then done := true;
	end;
      end;
      get_sline := done;
    end;{ get_sline }

  procedure add_to_reflist(var p:proc_name_type);
    var
      temp : ref_list_recp;
      found: boolean;
    begin
      temp := ref_list;
      found := false;
      while (not found) and (temp<>nil) do
      begin
	if temp^.pname^=p then found := true
			  else temp := temp^.next;
      end;
      if not found then
      begin
	new(temp);
	with temp^ do
	begin
	  pname := addr(p);
	  next  := ref_list;
	  ref_list := temp;
	end;
      end;
    end; { add_to_reflist}

  function find_state(var n:name_type):state_recp;
    var
      found : boolean;
      temp  : state_recp;
    begin
      temp := state_list;
      found := false;
      while (not found) and (temp<>nil) do
      with temp^ do
      begin
	if n=name then found := true
		  else temp := next;
      end;
      find_state := temp;
    end; { find_state }

  procedure make_state(var n:name_type);
    begin
      current_state := find_state(n);
      if current_state<>nil then
      begin
	if current_state^.procs_list<>nil then error(3);
      end
      else
      begin { create a state with default values }
	new(current_state);
	with current_state^ do
	begin
	  next       := nil;
	  name       := n;
	  state_class:= standard;
	  nprocs     := 0;
	  procs_list := nil;
	  exit_class := singles;
	  nexits     := 0;
	  exit_list  := nil;
	end;
	if last_state=nil then state_list := current_state
			  else last_state^.next := current_state;
	last_state := current_state;
      end;
    end; { make_state }

  procedure get_state_name;
    var
      sname : name_type;
      l : integer;
    begin
       all_done := current_option=end_machine;
       if not all_done then
       begin
	 l := breakstr(sline,1,' ');
	 if l = 0 then l := strlen(sline)+1;
	 if (l>=strlen(sline)) then error(1);
	 if (l>max_name_size) then error(2);
	 sname := str(sline,1,l-1);
	 make_state(sname);
	 try
	   strread(sline,l,l,current_state^.state_class);
	 recover error(5);
       end;
    end; { get_state_name }

  procedure add_state_proc(var last:proc_recp;
			   var scanning : boolean);
    var
      x    : proc_recp;
      s,e  : integer;
    begin
      s := spanstr(sline,1,' ');
      e := breakstr(sline,s,' ');
      if e = 0 then e := strlen(sline)+1;
      new(x);
      with x^ do
      begin
	pname := str(sline,s,e-s);
	if refs_on then
	begin
	  pname := mod_name + pname;
	  add_to_reflist(pname);
	end;
	next  := nil;
	with current_state^ do
	begin
	  nprocs := nprocs + 1;
	end;
      end;
      if last=nil then current_state^.procs_list := x
		  else last^.next := x;
      last := x;
    end; { add_state_proc }

  procedure get_state_procs;
    var scanning : boolean;
	last     : proc_recp;
    begin
      scanning := true;
      last     := nil;
      while scanning do
      begin
	if get_sline then scanning := sline[1]=' '
		     else scanning := false;
	if scanning then add_state_proc(last,scanning);
      end;
    end; { get_state_proc }

  procedure add_exit_state(var last:exit_recp);
    var
      x    : exit_recp;
      s,e  : integer;
      temp : state_recp;
      have_event : boolean;
    begin
      s := spanstr(sline,1,' ');
      e := breakstr(sline,s,' ,');
      if e = 0 then e := strlen(sline)+1;
      new(x);
      with x^ do
      begin
	if current_state^.exit_class in [pairs,pairs_catch] then
	begin
	  event := str(sline,s,e-s);
	  have_event := e<=strlen(sline);
	  if have_event then have_event := sline[e]=',';
	  if have_event then
	  begin
	    s := breakstr(sline,e,',')+1;
	    s := spanstr(sline,s,' ');
	    e := breakstr(sline,s,' ');
	    if e = 0 then e := strlen(sline)+1;
	    ename := str(sline,s,e-s);
	  end
	  else { no event field }
	  begin
	    ename := event;
	    event := '000';
	  end;
	end
	else ename := str(sline,s,e-s);
	next  := nil;
	temp  := find_state(ename);
	if temp=nil then
	begin
	  temp := current_state;
	  make_state(ename);
	  current_state := temp;
	end;
	with current_state^ do
	begin
	  nexits := nexits + 1;
	end;
      end;
      if last=nil then current_state^.exit_list := x
		  else last^.next := x;
      last := x;
    end; { add_exit_state }

  procedure get_state_exits;
    var
      scanning : boolean;
      last     : exit_recp;
    begin
      scanning := true;
      last     := nil;
      with current_state^ do
      case current_option of
      event_singles     : exit_class := singles;
      event_singles_catch:exit_class := singles_catch;
      event_pairs       : exit_class := pairs;
      event_pairs_catch : exit_class := pairs_catch;
      otherwise
	error(10);
      end;

      while scanning do
      begin
	if get_sline then scanning := sline[1]=' '
		     else scanning := false;
	if scanning then add_exit_state(last);
      end;
    end; { get_state_exits }

  procedure do_state;
    begin
      get_state_name;
      if not all_done then
      with current_state^ do
      begin
	case state_class of
	standard:
	       begin
		 get_state_procs;
		 get_state_exits;
	       end;
	mcall: begin
		 get_state_procs; { only 1 machine name }
		 if nprocs<>1 then error(7);
		 get_state_exits;
	       end;
	suspend:
	       begin
		 current_option := event_singles;
		 get_state_exits;
		 if nexits<>1 then error(6);
	       end;
	mexit,
	done_exit:
	       begin
		 refs_on := false;
		 get_state_procs; { only 1 value }
		 if nprocs<>1 then error(4);
		 refs_on := true;
	       end;
	otherwise
	   writeln('un implemented state class', state_class);
	   escape(0);
	end; { state_class }
      end;
    end; { do_state }

  procedure generate_machine;
    var
      tstate : state_recp;
      xlist  : exit_recp;
      plist  : proc_recp;
      rlist  : ref_list_recp;
      sc1    : state_class_type;
      sc2    : exit_class_type;
      option : string[80];
    begin
      { generate REFA, LMODE list }
      if find_state(g_recover)=nil then error(9);
      rlist := ref_list;
      while rlist<>nil do
      with rlist^ do
      begin
	writeln(mfile,' ':15,' REFA  ',pname^);
	writeln(mfile,' ':15,' LMODE ',pname^);
	rlist := next;
      end;
      { generate state machine definition }
      for sc1 := standard to done_exit do
      begin
	writeln(mfile,sc1,' equ ',ord(sc1):1);
      end;
      for sc2 := singles to pairs_catch do
      begin
	writeln(mfile,sc2,' equ ',ord(sc2):1);
      end;
      writeln(mfile);
      writeln(mfile,' ':15,' DEF   ',m_name);
      writeln(mfile,m_name,' ':15-strlen(m_name),' dc.w  ',g_recover,'-',m_name);
      tstate := state_list;
      while tstate<>nil do
      with tstate^ do
      begin
	write(mfile,name,' ':15-strlen(name));
	writeln(mfile,' dc.b    ',state_class,',',exit_class);
	case state_class of
	standard,
	mcall:
	  begin
	    if nprocs=0 then
	    begin
	      writeln('No procedures for state ',name);
	      escape(0);
	    end;
	    if nexits=0 then
	    begin
	      writeln('No exits defined for state ',name);
	      escape(0);
	    end;
	    {if exit_class in [singles_catch,pairs_catch] then nexits := nexits - 1;}
	    writeln(mfile,' ':15,' dc.b    ',nexits:1,',',nprocs:1);
	    xlist := exit_list;
	    while xlist<>nil do
	    with xlist^ do
	    begin
	      if exit_class in [pairs,pairs_catch] then
		writeln(mfile,' ':15,' dc.w    ',event,',',ename,'-',m_name)
	      else
		writeln(mfile,' ':15,' dc.w    ',ename,'-',m_name);
	      xlist := next;
	    end;
	    plist := procs_list;
	    while plist<>nil do
	    with plist^ do
	    begin
	      writeln(mfile,' ':15,' dc.l ',pname);
	      plist := plist^.next;
	    end;
	  end;
	suspend:
	  begin
	    with exit_list^ do
	    begin
	      writeln(mfile,' ':15,' dc.w    ',ename,'-',m_name);
	    end;
	  end;
	mexit,
	done_exit:
	  begin
	    with procs_list^ do
	    begin
	      writeln(mfile,' ':15,' dc.w ',pname);
	    end;
	  end;
	otherwise

	end; { case state_class }
	  writeln(mfile);
	tstate := tstate^.next;
      end;
      writeln(mfile);
      readln(option); option := strltrim(strrtrim(option));
      writeln(mfile,'* state trace table OPTION = ',option);
      if option = 'TABLE ON' then
      begin
	writeln(mfile,'   DEF ',m_name+'_T');
	writeln(mfile,m_name+'_T  equ * ');
	tstate := state_list;
	while tstate<>nil do
	with tstate^ do
	begin
	  writeln(mfile,' dc.w ',name,'-',m_name);
	  writeln(mfile,' dc.b ',strlen(name):1,',''',name,' ':17-strlen(name),'''');
	  tstate := tstate^.next;
	end;
	writeln(mfile,' dc.w 0'); { end of table }
      end;
    end; { generate_machine }

BEGIN
  writeln(version); writeln;
  write('Source  file name = ');readln(sname);
  reset(sfile,sname);
  write('Machine file name = ');readln(modname);
  rewrite(mfile,modname);
  ecode := 0;
  all_done := eof(sfile);
  mod_name := '';
  state_list := nil;
  last_state := nil;
  ref_list   := nil;
  refs_on    := true;
  current_option := none;
  TRY
    repeat
     if not get_sline then escape(1);
    until current_option<>none;
    if current_option<>machine_name then escape(1);
    writeln('state machine is ',m_name);
    current_option := none;
    repeat
     if not get_sline then escape(2);
    until current_option<>none;
    if current_option<>global_recover then escape(2);
    writeln('global recover state is ',g_recover);
    if get_sline then
    begin
      while not all_done do
      begin
	do_state;
      end;
      generate_machine;
    end
    else error(-1);
    writeln(mfile,'     END');
  RECOVER
    begin
      ecode := escapecode;
      if ecode=1 then writeln('machine_name not found')
      else
      if ecode=2 then writeln('global_recover not found');
      if ecode>0 then ecode := 0;
    end;
  close(sfile);
  close(mfile,'SAVE');
  if ecode<>0 then escape(ecode);
END.
@


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


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 570
$MODCAL$
$DEBUG ON$
PROGRAM MACHINE_MAKER(INPUT,OUTPUT);
{local search{{
$SEARCH 'MATCHSTR'$
{system search{}
$SEARCH 'PROGS:MATCHSTR'$
{}

IMPORT SYSGLOBALS,MATCHSTR;
CONST
  version = 'machine maker version 4.0';
  max_name_size = 16;
TYPE
  name_type = string[max_name_size];
  proc_name_type = string80;
  pnamep = ^proc_name_type;
  ref_list_recp = ^ref_list_rec;
  ref_list_rec = record
		   pname: pnamep;
		   next : ref_list_recp;
		 end;
  proc_recp = ^proc_rec;
  proc_rec  = record
	       pname : proc_name_type;
	       next  : proc_recp;
	      end;
  exit_class_type = (singles,singles_catch,pairs,pairs_catch);
  exit_recp = ^exit_rec;
  exit_rec = record
	       event : name_type;
	       ename : name_type;
	       next  : exit_recp;
	     end;
  state_class_type = (standard,mcall,mexit,suspend,done_exit);
  state_recp = ^state_rec;
  state_rec = record
		name    : name_type;
		state_class : state_class_type;
		nprocs : integer;
		procs_list : proc_recp;
		exit_class : exit_class_type;
		nexits : integer;
		exit_list : exit_recp;
		next : state_recp;
	      end;
  option_type = (none,module_name,
		 event_singles,event_singles_catch,
		 event_pairs,event_pairs_catch,
		 machine_name,global_recover,end_machine);
VAR
  sname,
  modname : string255;
  sfile,
  mfile : text;
  sline : string255;
  all_done : boolean;
  ecode : integer;
  {-----------------------}
  mod_name    : string80;
  m_name      : string80; { machine_name }
  g_recover   : name_type;
  state_list,
  last_state,
  current_state : state_recp;
  ref_list      : ref_list_recp;
  refs_on       : boolean;
  current_option: option_type;

  procedure error(n:integer);
    var x : integer;
    var es1 : string[80];
    begin
      es1 := '';
      case n of
     -1: es1 := 'empty file';
      0: es1 := 'unexpected EOF';
      1: es1 := 'invalid state definition';
      2: es1 := 'invalid state name';
      3: es1 := 'duplicate state definition'+current_state^.name;;
      4: es1 := 'require only one exit code for state '+current_state^.name;
      5: es1 := 'invalid state class : '+sline;
      6: es1 := 'require only one state reference for state '+current_state^.name;
      7: es1 := 'require only one machine reference for state '+current_state^.name;
      8: es1 := 'invalid option : '+sline;
      9: es1 := 'global recover state '+g_recover+' not defined ';
     10: strwrite(es1,1,x,'invalid exit class : ',current_option,
			  ' for state ',current_state^.name);
      otherwise
	strwrite(es1,1,x,'Error ',n:1);
      end; { case }
      writeln(mfile,'->->',es1);
      escape(0);
    end;

  procedure upper_case(var s:string);
    var i : integer;
    begin
      for i := 1 to strlen(s) do
	if s[i] in ['a'..'z'] then s[i] := chr(ord(s[i])-ord('a')+ord('A'));
    end; { upper_case }

  function get_sline:boolean;
    var
      done : boolean;
      i,j  : integer;
    begin
      done := false;
      while not done do
      begin
	current_option := none;
	if eof(sfile) then error(0);
	readln(sfile,sline);
	sline := strrtrim(sline);
	writeln(mfile,sline);
	if sline<>'' then
	if sline[1]='*' then
	begin
	  strdelete(sline,1,1);
	  upper_case(sline);
	  if strlen(sline)>1 then
	    if sline[1]='$' then
	    begin i := 2;
	      try
		strread(sline,i,i,current_option);
	      recover
		error(8);
	      case current_option of
	      module_name:
		begin
		  i := spanstr(sline,i,' ');
		  j := breakstr(sline,i,' ');
		  if j = 0 then j := strlen(sline)+1;
		  mod_name := str(sline,i,j-i);
		end;
	      machine_name:
		begin
		  i := spanstr(sline,i,' ');
		  j := breakstr(sline,i,' ');
		  if j = 0 then j := strlen(sline)+1;
		  m_name := str(sline,i,j-i);
		  done := true;
		end;
	      global_recover:
		begin
		  i := spanstr(sline,i,' ');
		  j := breakstr(sline,i,' ');
		  if j = 0 then j := strlen(sline)+1;
		  g_recover := str(sline,i,j-i);
		  done := true;
		end;
	      end_machine:
		begin
		  all_done := true; done := true;
		end;
	      otherwise
		done := true;
	      end; {case option}
	    end
	    else
	    if sline[1]<>'*' then done := true;
	end;
      end;
      get_sline := done;
    end;{ get_sline }

  procedure add_to_reflist(var p:proc_name_type);
    var
      temp : ref_list_recp;
      found: boolean;
    begin
      temp := ref_list;
      found := false;
      while (not found) and (temp<>nil) do
      begin
	if temp^.pname^=p then found := true
			  else temp := temp^.next;
      end;
      if not found then
      begin
	new(temp);
	with temp^ do
	begin
	  pname := addr(p);
	  next  := ref_list;
	  ref_list := temp;
	end;
      end;
    end; { add_to_reflist}

  function find_state(var n:name_type):state_recp;
    var
      found : boolean;
      temp  : state_recp;
    begin
      temp := state_list;
      found := false;
      while (not found) and (temp<>nil) do
      with temp^ do
      begin
	if n=name then found := true
		  else temp := next;
      end;
      find_state := temp;
    end; { find_state }

  procedure make_state(var n:name_type);
    begin
      current_state := find_state(n);
      if current_state<>nil then
      begin
	if current_state^.procs_list<>nil then error(3);
      end
      else
      begin { create a state with default values }
	new(current_state);
	with current_state^ do
	begin
	  next       := nil;
	  name       := n;
	  state_class:= standard;
	  nprocs     := 0;
	  procs_list := nil;
	  exit_class := singles;
	  nexits     := 0;
	  exit_list  := nil;
	end;
	if last_state=nil then state_list := current_state
			  else last_state^.next := current_state;
	last_state := current_state;
      end;
    end; { make_state }

  procedure get_state_name;
    var
      sname : name_type;
      l : integer;
    begin
       all_done := current_option=end_machine;
       if not all_done then
       begin
	 l := breakstr(sline,1,' ');
	 if l = 0 then l := strlen(sline)+1;
	 if (l>=strlen(sline)) then error(1);
	 if (l>max_name_size) then error(2);
	 sname := str(sline,1,l-1);
	 make_state(sname);
	 try
	   strread(sline,l,l,current_state^.state_class);
	 recover error(5);
       end;
    end; { get_state_name }

  procedure add_state_proc(var last:proc_recp;
			   var scanning : boolean);
    var
      x    : proc_recp;
      s,e  : integer;
    begin
      s := spanstr(sline,1,' ');
      e := breakstr(sline,s,' ');
      if e = 0 then e := strlen(sline)+1;
      new(x);
      with x^ do
      begin
	pname := str(sline,s,e-s);
	if refs_on then
	begin
	  pname := mod_name + pname;
	  add_to_reflist(pname);
	end;
	next  := nil;
	with current_state^ do
	begin
	  nprocs := nprocs + 1;
	end;
      end;
      if last=nil then current_state^.procs_list := x
		  else last^.next := x;
      last := x;
    end; { add_state_proc }

  procedure get_state_procs;
    var scanning : boolean;
	last     : proc_recp;
    begin
      scanning := true;
      last     := nil;
      while scanning do
      begin
	if get_sline then scanning := sline[1]=' '
		     else scanning := false;
	if scanning then add_state_proc(last,scanning);
      end;
    end; { get_state_proc }

  procedure add_exit_state(var last:exit_recp);
    var
      x    : exit_recp;
      s,e  : integer;
      temp : state_recp;
      have_event : boolean;
    begin
      s := spanstr(sline,1,' ');
      e := breakstr(sline,s,' ,');
      if e = 0 then e := strlen(sline)+1;
      new(x);
      with x^ do
      begin
	if current_state^.exit_class in [pairs,pairs_catch] then
	begin
	  event := str(sline,s,e-s);
	  have_event := e<=strlen(sline);
	  if have_event then have_event := sline[e]=',';
	  if have_event then
	  begin
	    s := breakstr(sline,e,',')+1;
	    s := spanstr(sline,s,' ');
	    e := breakstr(sline,s,' ');
	    if e = 0 then e := strlen(sline)+1;
	    ename := str(sline,s,e-s);
	  end
	  else { no event field }
	  begin
	    ename := event;
	    event := '000';
	  end;
	end
	else ename := str(sline,s,e-s);
	next  := nil;
	temp  := find_state(ename);
	if temp=nil then
	begin
	  temp := current_state;
	  make_state(ename);
	  current_state := temp;
	end;
	with current_state^ do
	begin
	  nexits := nexits + 1;
	end;
      end;
      if last=nil then current_state^.exit_list := x
		  else last^.next := x;
      last := x;
    end; { add_exit_state }

  procedure get_state_exits;
    var
      scanning : boolean;
      last     : exit_recp;
    begin
      scanning := true;
      last     := nil;
      with current_state^ do
      case current_option of
      event_singles     : exit_class := singles;
      event_singles_catch:exit_class := singles_catch;
      event_pairs       : exit_class := pairs;
      event_pairs_catch : exit_class := pairs_catch;
      otherwise
	error(10);
      end;

      while scanning do
      begin
	if get_sline then scanning := sline[1]=' '
		     else scanning := false;
	if scanning then add_exit_state(last);
      end;
    end; { get_state_exits }

  procedure do_state;
    begin
      get_state_name;
      if not all_done then
      with current_state^ do
      begin
	case state_class of
	standard:
	       begin
		 get_state_procs;
		 get_state_exits;
	       end;
	mcall: begin
		 get_state_procs; { only 1 machine name }
		 if nprocs<>1 then error(7);
		 get_state_exits;
	       end;
	suspend:
	       begin
		 current_option := event_singles;
		 get_state_exits;
		 if nexits<>1 then error(6);
	       end;
	mexit,
	done_exit:
	       begin
		 refs_on := false;
		 get_state_procs; { only 1 value }
		 if nprocs<>1 then error(4);
		 refs_on := true;
	       end;
	otherwise
	   writeln('un implemented state class', state_class);
	   escape(0);
	end; { state_class }
      end;
    end; { do_state }

  procedure generate_machine;
    var
      tstate : state_recp;
      xlist  : exit_recp;
      plist  : proc_recp;
      rlist  : ref_list_recp;
      sc1    : state_class_type;
      sc2    : exit_class_type;
      option : string[80];
    begin
      { generate REFA, LMODE list }
      if find_state(g_recover)=nil then error(9);
      rlist := ref_list;
      while rlist<>nil do
      with rlist^ do
      begin
	writeln(mfile,' ':15,' REFA  ',pname^);
	writeln(mfile,' ':15,' LMODE ',pname^);
	rlist := next;
      end;
      { generate state machine definition }
      for sc1 := standard to done_exit do
      begin
	writeln(mfile,sc1,' equ ',ord(sc1):1);
      end;
      for sc2 := singles to pairs_catch do
      begin
	writeln(mfile,sc2,' equ ',ord(sc2):1);
      end;
      writeln(mfile);
      writeln(mfile,' ':15,' DEF   ',m_name);
      writeln(mfile,m_name,' ':15-strlen(m_name),' dc.w  ',g_recover,'-',m_name);
      tstate := state_list;
      while tstate<>nil do
      with tstate^ do
      begin
	write(mfile,name,' ':15-strlen(name));
	writeln(mfile,' dc.b    ',state_class,',',exit_class);
	case state_class of
	standard,
	mcall:
	  begin
	    if nprocs=0 then
	    begin
	      writeln('No procedures for state ',name);
	      escape(0);
	    end;
	    if nexits=0 then
	    begin
	      writeln('No exits defined for state ',name);
	      escape(0);
	    end;
	    {if exit_class in [singles_catch,pairs_catch] then nexits := nexits - 1;}
	    writeln(mfile,' ':15,' dc.b    ',nexits:1,',',nprocs:1);
	    xlist := exit_list;
	    while xlist<>nil do
	    with xlist^ do
	    begin
	      if exit_class in [pairs,pairs_catch] then
		writeln(mfile,' ':15,' dc.w    ',event,',',ename,'-',m_name)
	      else
		writeln(mfile,' ':15,' dc.w    ',ename,'-',m_name);
	      xlist := next;
	    end;
	    plist := procs_list;
	    while plist<>nil do
	    with plist^ do
	    begin
	      writeln(mfile,' ':15,' dc.l ',pname);
	      plist := plist^.next;
	    end;
	  end;
	suspend:
	  begin
	    with exit_list^ do
	    begin
	      writeln(mfile,' ':15,' dc.w    ',ename,'-',m_name);
	    end;
	  end;
	mexit,
	done_exit:
	  begin
	    with procs_list^ do
	    begin
	      writeln(mfile,' ':15,' dc.w ',pname);
	    end;
	  end;
	otherwise

	end; { case state_class }
	  writeln(mfile);
	tstate := tstate^.next;
      end;
      writeln(mfile);
      readln(option); option := strltrim(strrtrim(option));
      writeln(mfile,'* state trace table OPTION = ',option);
      if option = 'TABLE ON' then
      begin
	writeln(mfile,'   DEF ',m_name+'_T');
	writeln(mfile,m_name+'_T  equ * ');
	tstate := state_list;
	while tstate<>nil do
	with tstate^ do
	begin
	  writeln(mfile,' dc.w ',name,'-',m_name);
	  writeln(mfile,' dc.b ',strlen(name):1,',''',name,' ':17-strlen(name),'''');
	  tstate := tstate^.next;
	end;
	writeln(mfile,' dc.w 0'); { end of table }
      end;
    end; { generate_machine }

BEGIN
  writeln(version); writeln;
  write('Source  file name = ');readln(sname);
  reset(sfile,sname);
  write('Machine file name = ');readln(modname);
  rewrite(mfile,modname);
  ecode := 0;
  all_done := eof(sfile);
  mod_name := '';
  state_list := nil;
  last_state := nil;
  ref_list   := nil;
  refs_on    := true;
  current_option := none;
  TRY
    repeat
     if not get_sline then escape(1);
    until current_option<>none;
    if current_option<>machine_name then escape(1);
    writeln('state machine is ',m_name);
    current_option := none;
    repeat
     if not get_sline then escape(2);
    until current_option<>none;
    if current_option<>global_recover then escape(2);
    writeln('global recover state is ',g_recover);
    if get_sline then
    begin
      while not all_done do
      begin
	do_state;
      end;
      generate_machine;
    end
    else error(-1);
    writeln(mfile,'     END');
  RECOVER
    begin
      ecode := escapecode;
      if ecode=1 then writeln('machine_name not found')
      else
      if ecode=2 then writeln('global_recover not found');
      if ecode>0 then ecode := 0;
    end;
  close(sfile);
  close(mfile,'SAVE');
  if ecode<>0 then escape(ecode);
END.
@


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


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


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


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


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


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


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


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


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


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


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


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


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


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


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


40.2
log
@MAKER updated to optionally include state table information, instead of always
including this information.
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@d4 1
a4 1
{{
d6 2
a8 1
$SEARCH 'PROGS:MATCHSTR'$
d419 1
d505 3
a507 6
      writeln(mfile,'* state trace table ');
      writeln(mfile,'   DEF ',m_name+'_T');
      writeln(mfile,m_name+'_T  equ * ');
      tstate := state_list;
      while tstate<>nil do
      with tstate^ do
d509 11
a519 3
	writeln(mfile,' dc.w ',name,'-',m_name);
	writeln(mfile,' dc.b ',strlen(name):1,',''',name,' ':17-strlen(name),'''');
	tstate := tstate^.next;
a520 1
      writeln(mfile,' dc.w 0'); { end of table }
@


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


1.2
log
@MATCHSTR used by Robert Quist does not match the system MATCHSTR.
MAKER modified to work with system MATCHSTR.
@
text
@@


1.1
log
@Initial revision
@
text
@d132 1
d139 1
d147 1
d242 1
d261 1
d305 1
d319 1
@
