{$symtab-,$linesize:131,$pagesize:86,
$title:'COMP.PAS -- Compiler for Scripts'}
{	COPYRIGHT @ 1982
	Jim Holtman and Eric Holtman
	35 Dogwood Trail
	Randolph, NJ 07869
	(201) 361-3395
}
module scrcomp;
var
    fil : text;
    state_number [public] : integer;
    gen_label_num [public] : integer;
    outf : text;
    comp_file_name [public] : lstring(20);
value
    state_number := 0;
    gen_label_num := 10000;
{$include:'token.h'}
{$include:'graph.inc'}
procedure savescreen;
    external;
procedure restorescreen;
    external;
procedure outstr(var fd : text; a,b,c,d : integer; const s : lstring);
begin
    writeln(fd,a,b,c,d,' ',s);
end;
function gen_lab : integer;
begin
    gen_label_num := gen_label_num + 100;
    gen_lab := gen_label_num;
end;
function sentence : integer;
    forward;
function next_token(var d : lstring; var fd : text) : integer;
    external;
procedure endxqq;
    external;
procedure print_error(const m:lstring;i : integer);
    external;
procedure putbchar(c : char);
    external;
procedure putbstr(const s : lstring);
    external;
procedure do_func(arg : integer);
var
    token : lstring(255);
    t : integer;
begin
    t := next_token(token, fil);
    if (t <> TOK_STR) then begin
	print_error('Error: String constant expected',ord(token.len));
	return;
    end;
    outstr(outf, state_number, arg, state_number+1, 0,token);
end;
procedure clause(go_lab, ret_lab : integer);
var
    o_stnum : integer;
    token : lstring(255);
    t_typ : integer;
begin
    o_stnum := state_number;
    state_number := go_lab;
    t_typ := next_token(token, fil);
    if (t_typ <> TOK_LBRACK) then begin
	putbchar(' ');
	putbstr(token);
	eval(sentence);
	outstr(outf, state_number+1, A_NGOTO, ret_lab, 0, 'non { return');
    end
    else begin
	repeat
	    t_typ := sentence;
	until t_typ = -1;
	outstr(outf, state_number, A_NGOTO, ret_lab, 0, 'return');
    end;
    state_number := o_stnum;
end;
procedure do_if;
var
    token : lstring(255);
    t_typ : integer;
    if_lab, else_lab : integer;
    onum : integer;
    otoken : lstring(255);
begin
    t_typ := next_token(token, fil);
    if (t_typ <> TOK_STR) then begin
	print_error('Error: string constant expected',ord(token.len));
	return;
    end;
    if_lab := gen_lab;
    else_lab := gen_lab;
    onum := state_number;
    copylst(token, otoken);
    clause(if_lab-1, state_number+1);
    t_typ := next_token(token, fil);
    if (t_typ <> TOK_ELSE) then begin
	putbchar(' ');
	putbstr(token);
	else_lab := onum + 1;
    end
    else begin
	clause(else_lab-1, state_number + 1);
    end;
    outstr(outf, onum, A_EXPECT, if_lab, else_lab,otoken);
end;
procedure do_case;
var
    token : lstring(255);
    t_typ : integer;
    case_lab : integer;
    st_lab : integer;
    onum : integer;
    otoken : lstring(255);
    done_other : boolean;
    other_lab : integer;
begin
    case_lab := gen_lab+1;
    other_lab := case_lab - 1;
    done_other := false;
    outstr(outf, state_number, A_CASE, case_lab, 0, 'CASE START');
    while true do begin
	t_typ := next_token(token, fil);
	if (t_typ <> TOK_LABEL) and (t_typ <> TOK_CASEEND) and (t_typ <> TOK_OTHERWISE) then begin
	    print_error('Error: LABEL or caseend expected',ord(token.len));
	    return;
	end;
	if (t_typ = TOK_CASEEND) then begin
	    if (done_other = false) then begin
		print_error('Warning: no OTHERWISE in CASE',ord(token.len));
		outstr(outf, other_lab, TOK_CASE, state_number+1, 0, 'OTHERWISE');
	    end;
	    outstr(outf, case_lab, TOK_CASEEND, 0, 0, token);
	    return;
	end
	else if (t_typ = TOK_OTHERWISE) then begin
	    if (done_other = true) then begin
		print_error('Error: more than one otherwise in CASE',ord(token.len));
		return;
	    end;
	    st_lab := gen_lab;
	    outstr(outf, other_lab, TOK_CASE, st_lab, 0, 'OTHERWISE');
	    clause(st_lab-1, state_number+1);
	    done_other := true;
	end
	else begin
	    delete(token, ord(token.len), 1);
	    st_lab := gen_lab;
	    outstr(outf, case_lab, TOK_CASE, st_lab, 0, token);
	    clause(st_lab-1, state_number+1);
	    case_lab := case_lab + 1;
	end;
    end;
end;
function sentence;
var
    token : lstring(255);
    t_typ : integer;
begin
    t_typ := next_token(token, fil);
    if (t_typ > -1) then begin
	state_number := state_number + 1;
	case t_typ of
	TOK_IF:
	    do_if;
	TOK_DIAL:
	    do_func(A_DIAL);
	TOK_SEND:
	    do_func(A_SEND);
	TOK_SAY:
	    do_func(A_SAY);
	TOK_GOTO:
	    do_func(A_LGOTO);
	TOK_GOSUB:
	    do_func(A_GOSUB);
	TOK_RETURN:
	    outstr(outf, state_number, A_RETURN, state_number+1, 0, 'return');
	TOK_LABEL:
	    begin
		token.len := token.len - 1;
		outstr(outf, state_number, A_LABEL, state_number+1, 0,token);
	    end;
	TOK_CLOSELOG:
	    begin
		outstr(outf, state_number, A_CLOSELOG, state_number+1, 0,'CLOSELOG');
	    end;
	TOK_TOGGLE_TR:
	    begin
		outstr(outf, state_number, A_TOGGLE_TR, state_number+1, 0,'TOGGLE_TR');
	    end;
	TOK_NAME:
	    do_func(A_ENTRY);
	TOK_RBRACK:
	    begin
		sentence := -1;
		return;
	    end;
	TOK_QUIT:
	    outstr(outf, state_number, -1, -1, -1, 'HALT');
	TOK_INPUT:
		do_func(A_INPUT);
	TOK_SETTIME:
		do_func(A_SETTIME);
	TOK_CASE:
		do_case;
	TOK_OPENLOG: do_func(A_OPENLOG);
	otherwise
	    begin
		print_error('Error: Unknown keyword', ord(token.len));
	return;
	    end;
	end;
    end;
    sentence := 0;
end;
procedure compile(var nam:lstring) [public];
begin
     savescreen;
     xxcls; xxmove(0,0);
     writeln('File "',nam,'" is not compiled.');
    assign(fil, nam);
    reset(fil);
    copylst(nam,comp_file_name);
    write('Name of file to contain compiled scripts: ');
    readln(nam);
    assign(outf, nam);
    rewrite(outf);
    writeln(outf,'#compiled');
    while (not eof(fil)) do eval(sentence);
    putbstr('quit '); eval(sentence);
    close(outf);
    writeln('Hit return to continue-----');
    readln;
    restorescreen;
end;
end.