%!
%    Copyright (C) 1992, 1996, 1998 Aladdin Enterprises.  All rights reserved.
% 
% This program is free software; you can redistribute it and/or modify it
% under the terms of the GNU General Public License as published by the
% Free Software Foundation; either version 2 of the License, or (at your
% option) any later version.
%
% This program is distributed in the hope that it will be useful, but
% WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
% Public License for more details.
%
% You should have received a copy of the GNU General Public License along
% with this program; if not, write to the Free Software Foundation, Inc.,
% 59 Temple Place, Suite 330, Boston, MA, 02111-1307.

% $Id: errpage.ps,v 1.2.6.1.2.1 2003/04/12 14:02:38 giles Exp $
% Print an informative error page if an error occurs.
% Inspired by Adobe's `ehandler.ps' and David Holzgang's PinPoint.

/EPdict 80 dict def
EPdict begin

/escale 12 def
/efont /Helvetica findfont escale scalefont def
/eheight escale 1.2 mul def

% Miscellaneous utilities
/xdef
 { exch def
 } bind def

% Define `show' equivalents of = and ==

/show=
 { =string { cvs } stopped { pop pop (==unprintable==) } if show
 } bind def

/.dict 18 dict def
.dict begin
  /.buf =string def
  /.cvp {.buf cvs show} bind def
  /.nop {(-) .p type .cvp (-) .p} bind def
  /.p {show} bind def
  /.p1 {( ) dup 0 4 -1 roll put show} bind def
  /.print
	{dup type .dict exch known
	 {dup type exec} {.nop} ifelse
	} bind def
  /integertype /.cvp load def
  /nulltype { pop (null) .p } bind def
  /realtype /.cvp load def
  /booleantype /.cvp load def
  /nametype
	{dup xcheck not {(/) .p} if
	 dup length .buf length gt
	  {dup length string}
	  {.buf}
	 ifelse cvs .p} bind def
  /arraytype
	{dup rcheck
	  {dup xcheck {(})({)} {(])([)} ifelse .p
	   exch () exch
	   {exch .p .print ( )} forall pop .p}
	  {.nop}
	 ifelse} bind def
  /operatortype
  	{(--) .p .cvp (--) .p} bind def
  /packedarraytype /arraytype load def
  /stringtype
	{dup rcheck
	  {(\() .p
	   {/.ch exch def
	    .ch 32 lt .ch 127 ge or
	    {(\\) .p .ch 8#1000 add 8 .buf cvrs 1 3 getinterval .p}
	    {.ch 40 eq .ch 41 eq or .ch 92 eq or
	     {(\\) .p} if
	     .ch .p1}
	    ifelse}
	   forall (\)) .p}
	  {.nop}
	 ifelse} bind def
end
/show==
 { .dict begin .print end
 } bind def

% Printing utilities

/eol
 { /ey ey eheight sub def
   ex ey moveto
 } bind def
/setx
 { /ex xdef ex ey moveto
 } bind def
/setxy
 { /ey xdef /ex xdef
   ex ey moveto
 } bind def
/indent
 { /lx ex def
   (    ) show currentpoint setxy
 } bind def
/unindent
 { lx setx
 } bind def

% Get the name of the n'th dictionary on the (saved) dictionary stack.
/nthdictname	% n -> name true | false
 { dup dstack exch get
   exch -1 0
    { dstack exch get
       { 2 index eq { exch pop exit } { pop } ifelse
       }
      forall
      dup type /nametype eq { exit } if
    }
   for
   dup type /nametype eq { true } { pop false } ifelse
 } bind def

% Find the name of a currently executing procedure.
/findprocname	% <proctail> findprocname <dstackindex> <procname> true
		% <proctail> findprocname false
 { dup length /proclength xdef
   dup type cvlit /proctype xdef
   dstack length 1 sub -1 0
    { dup dstack exch get
       { dup type proctype eq
          { dup rcheck { dup length } { -1 } ifelse proclength gt
	     { dup length proclength sub proclength getinterval 3 index eq
	        { 3 -1 roll pop exit }
		{ pop }
	       ifelse
	     }
	     { pop pop
	     }
	    ifelse
	  }
	  { pop pop
	  }
	 ifelse
       }
      forall
      dup type /nametype eq { exit } if
      pop
    }
   for
   dup type /nametype eq { true } { pop false } ifelse
 } bind def

% Error printing routine.
% The top 2 elements of the o-stack are systemdict and EPdict.
% For the moment, we ignore the possibility of stack overflow or VMerror.
/showerror	% <command> <countexecstack> <errorname> showerror -
 {
	% Restore the error handlers.

   saveerrordict { errordict 3 1 roll put } forall
   $error /recordstacks false put

	% Save information from the stacks.

   /saveerror xdef
   countexecstack array execstack
   0 3 -1 roll 1 sub getinterval
   /estack xdef
   /savecommand xdef

   countdictstack array dictstack
   dup length 2 sub 0 exch getinterval
   /dstack xdef

	% Save state variables that will be reset.
	% (We could save and print a lot more of the graphics state.)

   /savefont currentfont def
   mark { savefont /FontName get =string cvs cvn } stopped
    { cleartomark null }
    { exch pop dup length 0 eq { pop null } if }
   ifelse /savefontname xdef
   efont setfont

    { currentpoint } stopped { null null } if
   /savey xdef /savex xdef
   0 0
    { pop pop }
    { pop pop 1 add }
    { pop pop pop pop pop pop exch 1 add exch }
    { }
   pathforall
   /savelines xdef /savecurves xdef
   /savepathbbox { [ pathbbox ] } stopped { pop null } if def

   initmatrix

   clippath pathbbox
     /savecliptop xdef /saveclipright xdef
     /saveclipbottom xdef /saveclipleft xdef
   initclip

   initgraphics

	% Eject the current page.

   showpage

	% Print the page heading.

   18 clippath pathbbox newpath
   4 1 roll pop pop pop eheight sub 12 sub setxy
   product (Product: )
   statusdict /printername known
    { 100 string statusdict begin printername end
      dup length 0 gt
       { exch pop exch pop (Printer name: ) }
       { pop }
      ifelse
    }
   if show show eol
   (Interpreter version ) show version show eol
   (Error: ) show saveerror show= eol
   (Command being executed: ) show /savecommand load show= eol
   currentfile { fileposition } stopped
    { pop }
    { (Position in input file: ) show show= eol }
   ifelse eol

	% Print the current graphics state.

   (Page parameters:) show eol indent
   (page size: ) show
     gsave clippath pathbbox grestore
     exch 3 index sub show= (pt x ) show
     exch sub show= (pt) show pop eol
   (current position: ) show
   savex null eq
    { (none) show }
    { (x = ) show savex show= (, y = ) show savey show= }
   ifelse eol
   savelines savecurves add 0 eq
    { (current path is empty) show
    }
    { (current path: ) show savelines show= ( line(s), ) show
      savecurves show= ( curve(s)) show eol
      (path bounding box: ) show savepathbbox show==
    }
   ifelse eol
   (current font: ) show
     savefontname dup null eq
      { pop (--no name--) show }
      { show= ( ) show
        gsave
        savefontname findfont /FontMatrix get matrix invertmatrix
	grestore
        savefont /FontMatrix get matrix concatmatrix
	dup 1 get 0 eq 1 index 2 get 0 eq and
	1 index 4 get 0 eq and 1 index 5 get 0 eq and
	1 index 0 get 2 index 3 get eq and
	 { 0 get show= (pt) show }
	 { (scaled by ) show show= }
	ifelse
      }
     ifelse eol
   eol unindent

	% Print the operand stack.

   /stky ey def
   (Operand stack:) show eol indent
   count { show== eol } repeat
   eol unindent

	% Print the dictionary stack.

   (Dictionary stack:) show eol indent
   dstack length 1 sub -1 0
    { nthdictname { show= } { (<unknown>) show } ifelse eol
    } for
   eol unindent

	% Print the execution stack.

   280 stky setxy
   (Execution stack:) show eol indent
   estack length 1 sub -1 1
    { estack exch get
      dup type /operatortype eq
       { show= eol
       }
       { dup type dup /arraytype eq exch /packedarraytype eq or
          { dup xcheck
	     { dup rcheck
	        { findprocname
		   { show= nthdictname { ( in ) show show= } if eol
		   }
		  if
		}
		{ pop
		}
	       ifelse
	     }
	     { pop
	     }
	    ifelse
	  }
	  { pop
	  }
	 ifelse
       }
      ifelse
    } for eol unindent

	% Print the next few lines of input.
	% Unfortunately, this crashes on an Adobe printer.

(
   (Next few lines of input:) show eol indent
   /input currentfile def
   mark { 4
    { input ( ) readstring not { pop exit } if
      dup 0 get dup 10 eq
       { pop pop eol 1 sub dup 0 eq { pop exit } if }
       { dup 13 eq { pop pop } { pop show } ifelse }
      ifelse
    }
   loop } stopped cleartomark eol unindent
) pop

	% Wrap up.

   showpage
   quit

 } def

% Define the common procedure for handling errors.
/doerror
 { systemdict begin EPdict begin showerror
 } bind def

end

% Install our own error handlers.

/EPinstall
 { EPdict begin
   /saveerrordict errordict length dict def
   errordict saveerrordict copy pop
   errordict
    { pop [ /countexecstack load 2 index cvlit /doerror load /exec load ] cvx
      errordict 3 1 roll put
    } forall
   errordict /handleerror
     [ /countexecstack load /handleerror /doerror load /exec load
     ] cvx
   put
   end
 } bind def

EPinstall