! DVI driver for canon laser printer. Pruned from tex:canon for use as spooler
! with dmb:ncp2
! Changes from 2.2 : Has code for back to back ranges (not used yet)
!         from 2.3 : Reads in .pam file is one is present
!         from 2.4 : Has extra parameter pagesprinted which is passed back to
!                    main program. Contains the number of pages sent to the
!                    printer. Also writes pxl filename to database if nb option
!                    is turned on.

%include "TeX:util"
%include "inc:region.imp"

%constinteger FRAMEHEIGHT=3500,FRAMEWIDTH=2560,
              FRAMEMULT=framewidth//8, FRAMEINC=-framemult,
              FRAMESIZE=frameheight*framemult

%constinteger VUPI=300, HUPI=300;  !vertical/horizontal units per inch
%constinteger PRINTHEIGHT=3500, PRINTWIDTH=2400

%external %byte %integer %array %name FRAME(0:framesize-1);  !or *2

%external %routine PRINT DVI FILE(%string(255) fname,
                                  %integer %name pagesprinted)

!!!!!!!!!!!!!!!!!!!!!!!!!!  Device Control Section  !!!!!!!!!!!!!!!!!!!!!!!!

%option"-low"

%own %integer newframe = 1

%routine RESET FRAME
%label loop
%bytename p
%integer q
   p == frame(0)
   q = framesize
  *move.l p,a0
  *move.l q,d1
  *moveq #0,d0
loop:
  *move.l d0,(a0)+
  *subq.l #4,d1
  *bpl    loop
  newframe = 0
%end

%routine PRINT PAGE

@16_7FFE0%short %integer prdata
@16_7FFE2%short %integer prdataeol
@16_7FFE4%short %integer cntrstat
@16_7FFE8%short %integer commstat
@16_7FFEC%short %integer interrupten
%constant %shortinteger doprint=1,controlready=8,
       fifoempty=1,fifohalffull=2,fifofull=4,pageout=8,printerready=16,
       statusready=32,commandready=64,printerpowerready=128,
       halffullen=1,pageouten=2,npageouten=4,statusreadyen=8

%constinteger vcount=frameheight-1, hcount=printwidth//16-1,
              print=controlready+doprint,
              topmargin=130
@16_400100%short PTM13
@16_400102%short PTM2
%bytename framebase
%integer i
framebase == frame(0)

!Silence timer
  ptm2 = 0;                    !select PTM3
  ptm13 = 0
  ptm2 = 16_0100;              !select PTM1
  ptm13 = 0
notdone:
  *move.w cntrstat,d2
  *and.w #pageout,d2
  *bne notdone
  i = prdata;                  !reset [eventually]
  cntrstat = controlready
  %for i = 1,1,topmargin %cycle
    prdataeol = 2
  %repeat
!Load registers
  *move framebase,a0
  *move #0,d0
  *move #vcount,d1      {outer loop D1
  *move.w #print,cntrstat;  !start device
notready:
  *move.w cntrstat,d2
  *and.w #pageout,d2
  *beq notready
  *move.w #controlready,cntrstat
!Send data
loop1:
  *move.w cntrstat,d2
  *and.w #fifohalffull,d2
  *bne loop1
!Left margin 16 (15+1) *16
  *move #15,d2
loop11:
  *move.w d0,prdata
  *dbra d2,loop11
!Data for line
  *move a0,a1
  *move #hcount,d2   {inner loop D2
loop2:
  *move.w (a1)+,prdata
  *dbra d2,loop2
  *move.w #0,prdataeol
  *lea framemult(a0),a0
  *dbra d1,loop1

  pagesprinted = pagesprinted+1
%end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%constant %string (6) default dvi directory name = "T_tek:"
%constant %string(255) database = "TeX:fontdb"

%const %string(60) banner = "This is DMB DVI Canon driver, Vers. 2.5"

%own %integer max fonts,
              store space,
              copies,
              control flags,
              left margin,
              top margin,
              new mag

%constant %integer name length = 12,
                   terminal channel=0,
                   dvi channel = 1,
                   tfm channel = 2,
                   dbchannel = 3,
                   param channel = 4,
                   no parm = -123456789,
                   infinity = (-1)>>1,
                   invalid width = infinity,
                   safety margin = 10000,
                   static  = 1,
                   dynamic = 2,
                   true = 1,
                   false= 0

%constant %byte id byte = 2

%constant %integer debug flag = 1<<31,
                   error flag = 1<<30,
                   phase flag = 1<<29,
                   fonts flag = 1<<28,
                   pages flag = 1<<27,
                   info  flag = 1<<26,
                   pause flag = 1<<25,
                   quiet flag = 1<<24,
                   backd flag = 1<<23,
                   vcent flag = 1<<22,
                   hcent flag = 1<<21,
                   dynld flag = 1<<20,
                   nodb  flag = 1<<19

%constant %integer  text flag mask = error flag ! %c
                                     phase flag ! %c
                                     fonts flag ! %c
                                     pages flag ! %c
                                     info  flag
                                     
%own %string (255) dvi file name, print sets, paramfile

%integer cur loc=0,
         max widths,
         nf=0, showing=0,
         loading,
         numerator, denominator, mag,
         doc width, doc height,
         doc left margin, doc top margin,
         total pages,
         stack size,
         back pointer, post pointer

%real conv, true conv, resolution

{*****************************************************************************}

%predicate CONTROL FLAG(%integer n)

   %if n & text flag mask # 0 %start
      %false %if control flags & quiet flag = quiet flag
      %true  %if control flags & debug flag = debug flag
   %finish
   %false %if control flags & n=0
   %true
%end   { control flag }


%routine ABORT(%string(255) why)

   %if control flag(error flag) %start
      print string (why); newline
   %finish
   %signal %event 15
%end   { abort }


%routine CAPACITY(%string (127) overflow)

   abort("---DVItype capacity exceeded (".overflow.")!")
%end   { capacity }


%routine BAD DVI(%string (127) error)

   abort("Bad DVI file: ".error."!")
%end   { bad dvi }


%predicate OPEN INPUT CHANNEL(%string(127) file name, %integer channel)

   %on %event 3,9 %start
      %false
   %finish
   %false %unless exists(file name)
   open input (channel, file name)
   %true
%end   { open input channel }


%routine DIALOG

   %string(31) ext

   dvi file name = fname
   define param("INPUT --- dvi file", dvi file name, 0)
   print sets = ""
   define param("DO --- print which pages", print sets, 0)
   copies = 1
   define int param("COPIES", copies, 0)
   store space=10000
   define int param("SYMBOLS", store space, 0)
   new mag   =    0
   define int param("MAGnification", new mag, 0)
   left margin =  0
   define int param("LEFT margin", left margin, 0)
   top margin  =  0
   define int param("TOP margin", top margin, 0)
   control flags     =  error flag + phase flag + info flag
   define boolean params("DEBUG,ERRORS,PHASE,FONTS,PAGES,INFO,PAUSE,QUIET," %c
                        ."BACK,VCENTre,HCENTre,DYNamic,NODB", control flags, 0)
   cliparam = ""
   dvi file name -> paramfile.(".").ext
   paramfile = paramfile.".pam"
   %if exists(paramfile) %start
     %unless open input channel(paramfile, param channel) %start
       printstring("Couldn't open parameter file"); newline
     %else
       select input(param channel)
       readline(cliparam)
       close input
     %finish
   %finish
   process parameters(cli param)
   %if control flag(info flag) %start
      print string (banner); newlines(2)
   %finish
   %if control flag(nodb flag) %start
     printstring("Database update suppressed");newline
   %finish
   copies = |copies|
   %if copies#1 %and control flag(info flag) %start
     print string("- doing"); write(copies,1); print string(" copies.")
     newline
   %finish
   dvi file name = dvi file name .".DVI" %unless dvi file name -> (".")
   %unless exists(dvi file name) %start
      %unless dvi file name -> (":") %start
         dvi file name = default dvi directory name . dvi file name
         -> file ok %if exists(dvi file name)
      %else
         bad dvi(dvi file name." doesn't exist!")
      %finish
   %finish
file ok:
   bad dvi("Can't open ".dvi file name."!") %unless %c
      open input channel(dvi file name, dvi channel)
   resolution = vupi
%end   { dialog }


%routine READ BYTE(%byte %name byte)

   %on %event 9 %start
      byte=0
      %return
   %finish
   read symbol(byte)
%end   { read byte }


%integer %function GET BYTE

   %byte b
   %integer c
   read byte(b)
   cur loc = cur loc+1
   c <- b&255
   %result = c
%end   { get byte }


%integer %function SIGNED BYTE

   %byte b
   read byte(b)
   cur loc = cur loc+1
   %result = b %if b<128
   %result = b-256
%end   { signed byte }


%integer %function GET TWO BYTES

   %byte a,b
   read byte(a); read byte(b)
   cur loc = cur loc+2
   %result = a*256 + b
%end   { get two bytes }


%integer %function SIGNED PAIR

   %byte a,b
   read byte(a); read byte(b)
   cur loc = cur loc+2
   %result = a*256+b %if a<128
   %result = (a-256)*256+b
%end   { signed pair }


%integer %function GET THREE BYTES

   %byte a,b,c
   read byte(a); read byte(b); read byte(c)
   cur loc = cur loc+3
   %result = (a*256+b)*256+c
%end   { get three bytes }


%integer %function SIGNED TRIO

   %byte a,b,c
   read byte(a); read byte(b); read byte(c)
   cur loc = cur loc+3
   %result = (a*256+b)*256+c %if a<128
   %result = ((a-256)*256+b)*256+c
%end   { signed trio }


%integer %function SIGNED QUAD

   %byte a,b,c,d
   read byte(a); read byte(b); read byte(c); read byte(d)
   cur loc = cur loc + 4
   %result = ((a*256+b)*256+c)*256+d %if a<128
   %result = (((a-256)*256+b)*256+c)*256+d
%end   { signed quad }


%routine PRINT REAL(%real number, %integer int len, frac len)

   print string(rtos(number, int len, frac len))
%end   { print real }


%routine SKIP FONT

   %integer dud,count,i
   dud=signed quad
   dud=signed quad
   dud=signed quad
   count=get byte+get byte
   dud=getbyte %for i=1,1,count
%end   { skip font }


%routine SKIP BYTES(%integer bytes)

  %integer loop
  %byte x

  %for loop=1,1,bytes %cycle
    readsymbol(x)
  %repeat
%end   { skip bytes }


%routine GETSTRING(%string(10) %name s,%integer len)

  %integer loop

  s = ""
  %for loop = 1,1,len %cycle
    s = s.tostring(getbyte)
  %repeat
%end   { getstring }


%routine READ PREAMBLE

   %integer p,k,i

   p = get byte
   %unless p=247 %start
      bad dvi("First byte isn't start of preamble!")
   %finish
   p = get byte
   %unless p=id byte %start
      bad dvi("identification in byte 1 should be ".itos(id byte,1)."!")
   %finish
   numerator = signed quad
   denominator = signed quad
   bad dvi("numerator is not positive") %unless numerator>0
   bad dvi("denominator is not positive") %unless denominator>0
   conv = (numerator/254000.0)*(resolution/denominator)
   mag = signed quad
   mag = new mag %if new mag > 0
   bad dvi("magnification is not positive") %unless mag>0
   true conv = conv
   conv = true conv*(mag/1000.0)
   p=get byte
   %if control flag(info flag) %start
      print string ("File: "); print string (dvi file name)
      print string(" --- '")
      print symbol(get byte) %for k=1,1,p
      print symbol('''')
      newline
      print string("magnification="); write(mag,1)
      print string("; "); print real(conv,16,8)
      print string(" pixels per DVI unit"); newline
   %else
      i = get byte %for k=1,1,p
   %finish
%end   { read preamble }


%routine READ POSTAMBLE

   %byte %array buffer (0:1023)
   %byte pad symbol
   %integer p,k,q,a,l
   %byte %name pointer

   access file(dvi file name, 0, k, p)
   q=0
   pointer == buffer(0)
   pad symbol = 0
   %cycle
      %if q<5 %start
         p=p+q
         q=1024
         q=p %if q>p
         p=p-q
         bad dvi("null file") %if q<5
         read region(k, p, q, pointer)
      %finish
      q=q-1
      pad symbol = 16_DF %if buffer(q)#0
   %repeat %until buffer(q)#pad symbol
   deaccess file(k)
   %unless buffer(q)=id byte %start
      bad dvi("id byte in post-post-amble should be".itos(id byte,1)."!")
   %finish
   p = (buffer(q-4)<<24) ! (buffer(q-3)<<16) ! (buffer(q-2)<<8) ! buffer(q-1)
   post pointer = p+29
   set input(p+1)

   back pointer = signed quad
   %if signed quad # numerator %and control flag(error flag) %start
      print string("postamble numerator doesn't match the preamble!")
      newline
   %finish
   %if signed quad # denominator %and control flag(error flag) %start
      print string("postamble denominator doesn't match the preamble!")
      newline
   %finish
   %if signed quad # mag %start
      %if new mag#0 %and control flag(error flag) %start
         print string("postamble magnification doesn't match the preamble!")
         newline
      %finish
   %finish
   doc height = signed quad
   doc width  = signed quad
   %if control flag (hcent flag) %start
      doc left margin = print width//2 - int(conv*doc width/2)-49 + left margin
   %else
      doc left margin = left margin + 300-84+16  { fudges to get margins right.}
   %finish
   %if control flag (vcent flag) %start
      doc top margin = print height//2 - int(conv*doc height/2)-75 + top margin
   %else
      doc top margin = top margin + 300-67+9 { more fudges.}
   %finish
   stack size = get two bytes
   total pages = get two bytes
   max fonts = 0
   %cycle
      k = get byte
      %if 243 <= k <= 246 %start
         p=get byte %and k=k-1 %until k=242
         max fonts = max fonts+1
         skip font
         k=138
      %finish
   %repeat %until k#138
%end   { read postamble }

{*****************************************************************************}

%on %event 2, 15 %start
   %if event_event=2 %start
      %if control flag(error flag) %start
         print string(" --- Sorry, not enough memory.");newline
      %finish
   %finish
   -> jump out
%finish

!open append(1,"tex:spdebug")
!select output(1)
!printstring("At very start of ecanon freestore = ")
!write(freestore,0); newline
!close output;

select output(terminal channel)
dialog
read preamble
read postamble
max widths = 128*max fonts

{*****************************************************************************}

   %begin   { 2 }

   %constant %string  (4) root="T_", sep sym=":", fil typ=".PX"
   %constant %integer number of directories = 9
   %constant %integer %array directory names(1:number of directories) =
              1200, 1500, 1643, 1800, 2160, 2592, 3110, 3732, 4479

   %string(name length)%array font name (0:max fonts)
   %integer %array font num,
                   font check sum,
                   font scaled size,
                   font design size,
                   font space (0:max fonts),
                   width,
                   pixel width (0:max widths),
                   page pointer(1:total pages),
                   count (1:total pages, 0:9)

   %string(4)%array font directory(0:max fonts)

   %string(10) %array myfontname(0:max fonts)
   %string(20) %array myfilename(0:maxfonts)
   %byte %array fonts(0:max fonts)
   %integer %array fontsize(0:max fonts)


   %integer current page, copy,
            my current page,
            start double, end double, double page,
            h,v,w,x,y,z,hh,vv,
            next page, start page,
            pixel space,
            fontcount = 0

   %byte %array output mode(1:total pages)
   %byte %array copies reqd(1:total pages)
 
   %byte output mode flag

{*****************************************************************************}
   
   %predicate READ IN PAGE NUMBER

      %integer i, j, flags, spec
      %integer %array start(0:9)

      %routine SKIP SPACES

         skip symbol %while next symbol =' '
      %end   { skip spaces }

      %integer %function READ INTEGER

         %constant %integer max int= ((-1)>>1)//10
         %integer number, sign

         number=0; sign=1
         %if next symbol='-' %start
            skip symbol
            sign = -1
         %finish
         %while '0'<=next symbol<='9' %cycle
            number=number*10 - '0' + nextsymbol %unless number>=max int
            skip symbol
         %repeat
         %result = number*sign
      %end   { read integer }

      %on %event 3,4,9 %start
         %false
      %finish

      { Start of read in page number }
      spec =-1; flags = 0
      %cycle
         skip symbol %while next symbol <=' '
         %if next symbol = '-' %or '0'<=next symbol<='9' %start
            i = read integer
            %unless spec=9 %start
               spec = spec+1
               start(spec)=i
               flags = flags ! (1<<spec)
            %finish
         %else %if next symbol='*'
            skip symbol
            spec = spec+1 %unless spec=9
         %else
            write(next symbol,0); newline
            %exit
         %finish
         skip spaces
         %exit %unless next symbol='.'
         skip symbol
      %repeat
      skip spaces
      %if next symbol='#' %or next symbol=',' %start
         skip symbol
         start page = read integer
         %false %if start page<=0
         skip spaces
      %else
         start page = 1
      %finish

      %if control flag(debug flag) %start
         %for i=0,1,spec %cycle
            print symbol('.') %unless i=0
            write(start(i),0)
         %repeat
         print symbol('#'); write(start page,0); newline
      %finish

      read symbol(i) %until i=nl

      %if spec=-1 %start
         %true %if start page<=total pages
         %false
      %finish
      
      %for i=1,1,total pages %cycle
         %for j=0,1,spec %cycle
            %exit %if flags & (1<<j) # 0 %and start(j)#count(i,j)
            %if j=spec %start
               start page = start page-1
               %if start page=0 %start
                  start page=i
                  %true
               %finish
            %finish
         %repeat
      %repeat
      %false
   %end   { read in page number }


   %routine PRINT FONT(%integer f)

      %if f=nf %start
         print string("Undefined!")
      %else
         print string (font name(f))
      %finish
   %end   { print font }


   %routine DISPLAY FONT(%integer f)

      %own %integer last printed=-1
      %integer k,n

      %if last printed=f %then spaces(3) %else %start
         last printed=f
         font num(nf)=f
         n=0
         n=n+1 %while font num(n)#f
         print string("Font")
         write(f,4)
         print string(": ")
         %if n=nf %start
            print string("Undefined!")
         %else %if font name(n)=""
            print string("null font name!")
         %else
            print string(font name(n))
         %finish
      %finish
   %end   { display font }


   %integer %function FIRST PAR(%byte o)

      %switch case of(128:255)

      %result=o %if o<128
      -> case of(o)
   !  set 1, put 1, fnt 1, xxx 1, fnt def 1
   case of(128):case of(133):case of(235):case of(239):case of(243):
      %result=get byte
   
   !  set 2, put 2, fnt 2, xxx 2, fnt def 2
   case of(129):case of(134):case of(236):case of(240):case of(244):
      %result=get two bytes
   
   !  set 3, put 3, fnt 3, xxx 3, fnt def 3
   case of(130):case of(135):case of(237):case of(241):case of(245):
      %result=get three bytes
   
   !  right 1, w1, x1, down1, y1, z1
   case of(143):case of(148):case of(153):case of(157):case of(162):case of(167):
      %result=signed byte
   
   !  right 2, w2, x2, down2, y2, z2
   case of(144):case of(149):case of(154):case of(158):case of(163):case of(168):
      %result=signed pair
   
   !  right 3, w3, x3, down3, y3, z3
   case of(145):case of(150):case of(155):case of(159):case of(164):case of(169):
      %result=signed trio
   
   !  set4,put4,fnt4,xxx4,fnt def4; right4,w4,x4,down4,y4,z4; set rule,put rule
   case of(131):case of(136):case of(238):case of(242):case of(246):
   case of(146):case of(151):case of(156):case of(160):case of(165):case of(170):
   case of(132):case of(137):
      %result=signed quad
   
   !  w0
   case of(147):  %result=w
   !  x0
   case of(152):  %result=x
   !  y0
   case of(161):  %result=y
   !  z0
   case of(166):  %result=z
   
   !  nop, bop, eop; push, pop, pre, post, post-post
   case of(138):case of(139):case of(140):
   case of(141):case of(142):case of(247):case of(248):case of(249):
      %result=0
   
   !  fnt num 0 ... fnt num 63
   case of(171):case of(172):case of(173):case of(174):case of(175):case of(176):
   case of(177):case of(178):case of(179):case of(180):case of(181):case of(182):
   case of(183):case of(184):case of(185):case of(186):case of(187):case of(188):
   case of(189):case of(190):case of(191):case of(192):case of(193):case of(194):
   case of(195):case of(196):case of(197):case of(198):case of(199):case of(200):
   case of(201):case of(202):case of(203):case of(204):case of(205):case of(206):
   case of(207):case of(208):case of(209):case of(210):case of(211):case of(212):
   case of(213):case of(214):case of(215):case of(216):case of(217):case of(218):
   case of(219):case of(220):case of(221):case of(222):case of(223):case of(224):
   case of(225):case of(226):case of(227):case of(228):case of(229):case of(230):
   case of(231):case of(232):case of(233):case of(234):
      %result=o-171
   
   case of(*): 
      %result=0
   %end   { first par }


   %predicate OPEN APPEND CHANNEL(%string(127) filename, %integer channel)
   
     %on %event 3,9 %start
       %false
     %finish
   
     %false %unless exists(filename)
     open append(channel,filename)
     %true
   %end   { open append channel }


   %routine APPEND DATABASE
   
     %integer loop
   
     %on %event 9,2 %start
       select output(terminal channel)
       printstring("Error writing database file");newline
       -> out
     %finish
   
     select output(terminal channel)
     printstring("Writing out database");newline
     select output(dbchannel)
     printstring(dvi filename);newline
     write(fontcount,0);newline
     %for loop=0,1,fontcount-1 %cycle
       write(fonts(loop),0)
       printsymbol(9)
       printstring(myfontname(loop))
       printsymbol(9)
       write(fontsize(loop),0)
       printsymbol(9)
       printstring(myfilename(loop))
       newline
     %repeat
     close output
   out:
   %end   { append database }


   %routine FINISH READING POST AMBLE

      %integer k,p, error

      %routine EXAMINE FONT(%integer e)

         %constant %integer file name length = 2+4+1+name length+4
         %integer f,c,d,k,n,p,q,mismatch
         %string(file name length) file name

         %predicate BEST FONT(%string(file name length)%name file,
                              %integer %name error,
                              %integer q, d)

            %real %array ratio (1:number of directories)
            %integer %array dir(1:number of directories)

            %string(name length) base
            %real reqd, rtemp
            %integer i,j, itemp

            base = file
            reqd = resolution*5 * q/d * conv/true conv

            %for i=1,1,number of directories %cycle
               dir(i) = directory names(i)
               rtemp = float(dir(i))
               %if reqd > rtemp %then ratio(i)=reqd/rtemp %elsec
                                      ratio(i)=rtemp/reqd
            %repeat

            %for i=1,1,number of directories %cycle
               %for j=i+1,1,number of directories %cycle
                  %if ratio(j)<ratio(i) %start
                     rtemp=ratio(i); ratio(i)=ratio(j); ratio(j)=rtemp
                     itemp = dir(i);  dir (i)= dir (j); dir (j) =itemp
                  %finish
               %repeat
               file=""
               error = int(100 * ratio(i))
               %for j=1,1,4 %cycle
                  itemp = dir(i)//10
                  file = to string('0'-10*itemp+dir(i)).file
                  dir(i) = itemp
               %repeat
               font directory(nf) = file
               file = root.file.sep sym.base.fil typ
               %true %if exists(file)
            %repeat
            font directory(nf)="none"
            %false
         %end   { best font }


         { Start of examine font }
         capacity("max fonts") %if nf = max fonts
         font num(nf)=e
         fonts(fontcount) = e
         f=0
         f=f+1 %while font num(f)#e
         c=signed quad; font check sum(nf)=c
         q=signed quad; font scaled size(nf)=q
         d=signed quad; font design size(nf)=d
         p=get byte; n=get byte
         file name = ""
         n=n+p
         capacity("max font name length") %if n > name length
         %for k=0,1,n-1 %cycle
            p = get byte
            p = p-'a'+'A' %if 'a' <= p <= 'z'
            file name = file name. to string(p)
         %repeat
         %if f=nf %start
            font name(f) = file name
            myfontname(fontcount) = file name
            %unless best font (filename, error, q,d) %start
               %if control flag(fonts flag + error flag) %start
                  nf = nf+1; display font(e); nf=nf-1
                  print string("---not loaded, PXL file can't be opened!")
                  newline
               %finish
            %else %if q<0 %or q>1<<27
               %if control flag(fonts flag + error flag) %start
                  nf = nf+1; display font(e); nf=nf-1
                  print string("---not loaded, bad scale")
                  newline
               %finish
            %else %if d<0 %or d>1<<27
               %if control flag(fonts flag + error flag) %start
                  nf = nf+1; display font(e); nf=nf-1
                  print string("---not loaded, bad design size!")
                  newline
               %finish
            %else
               myfilename(fontcount) = filename
               font space(nf) = q//6
               k = file size(file name)//4 - 517
               pixel space = pixel space + k
               nf=nf+1; font space(nf)=0
               fontsize(fontcount) = q
               fontcount = fontcount+1
               %if control flag(fonts flag) %start
                  display font(e)
                  d = int((100.0*conv*q)/(true conv*d))
                  print string("---to be loaded at size "); write(q,1)
                  print string(" DVI units; (");
                  write(k*4,1); print string("ish bytes)")
                  %if d#100 %start
                     newline
                     print string (" (this font is magnified ")
                     write(d-100,1)
                     print string ("%)")
                  %finish
                  %if error#100 %start
                     newline
                     print string(" (this pixel file is magnified ")
                     write(error-100,1)
                     print string ("%)")
                  %finish
                  newline
               %finish
            %finish
         %else %if control flag(fonts flag + error flag)
            display font(e)
            print string("---this font was already defined!"); newline
            %if font check sum(f)#c %start
               print string("---check sum doesn't match previous definition!")
               newline
            %finish
            %if font scaled size(f)#q %start
               print string("---scaled size doesn't match previous definition!")
               newline
            %finish
            %if font design size(f)#d %start
               print string("---design size doesn't match previous definition!")
               newline
            %finish
            mismatch=false
            %for k=1,1,n+p %cycle
               mismatch=true %unless char no(font name(f),k)=get byte
            %repeat
            %if mismatch=true %start
               print string("---font name doesn't match previous definition!")
               newline
            %finish
         %finish
      %end   { examine font }


      { Start of finish reading postamble }
      cur loc=post pointer; set input(post pointer)
      %cycle
         k = get byte
         %if 243 <= k <= 246 %start
            p = first par(k)
            examine font(p)
            k=138
         %finish
      %repeat %until k#138

      %unless control flag(nodb flag) %start
        %if open append channel(database,dbchannel) %then %start
          append database
          select output(terminal channel)
        %finish %else %start
          select output(terminal channel)
          printstring(database. " not found. (Don't Panic)")
          newline
        %finish
      %finish
   %end   { finish reading postamble }

!   open append(1,"tex:spdebug")
!   select output(1)
!   printstring("At second begin freestore = ")
!   write(freestore,0); newline
!   close output
!   select output(0)

   w=0; x=0; y=0; z=0
   pixel space = 0
   font name(0)=""
   font space(0)=0
   set terminal mode(no page)
   finish reading postamble

{*****************************************************************************}
      %begin   { 3 }
     
      %integer stored
      %integer  k,p
   
      %record %format char info ((%short pwidth, pheight,
                                         xoffset, yoffset,
                                  %integer file, load) %orc
                                 (%byte bc,bd,be,bf, b8,b9,ba,bb,
                                      reqd,b5,b6,b7, b0,b1,b2,b3))
   
      %record (char info) %array char dir(0:max widths+2)
   
      %record %format entry (%short type, code, x, y)
    
      %record (entry) %array store(0:store space)
   
   
      %routine PASS BOPS SETTING COUNT
   
         %integer page count, k
   
         %for page count = total pages, -1, 1 %cycle
            set input(back pointer+1)
            page pointer(page count) = back pointer
            count(page count, k)=signed quad %for k=0,1,9
            %if control flag(pages flag) %start
               print string("#");write(pagecount,4);printstring("@")
               write(back pointer,6); print string(" :")
               write(count(pagecount,k),1) %for k=0,1,9
               newline
            %finish
            back pointer = signed quad
         %repeat
      %end   { pass bops setting count }
   
   
      %routine DEFINE FONTS
   
         %integer pixel size, pixel base
         %integer f,p,n,c,q,d,j,k,mismatch, width ptr, tfm checksum
         %string(255) current file name, name
   
         %predicate BLOCK LOAD INFO(%string(255) file name)
   
            %integer size, split, ref
            %bytename buffer
            %integer %array temp (0:127)
   
            %false %unless exists(file name)
   
            access file (file name, 0, ref, size)
            buffer == byte integer(addr(temp))
            %cycle
               %false %if size < (1+512+5)*4
               split=128
               size = size-512
               read region(ref, size, 512, buffer)
               split=split-1 %until split=0 %or temp(split)=1001
            %repeat %until temp(split)=1001
            size = size + split*4 + 4
            pixel size = size - (1+512+5)*4
            %if loading=static %start
               pixel base = heap get(pixel size)
               buffer == byte integer(pixel base)
        { grab pixel size bytes from heap, put address into pixel base & buffer}
               read region(ref, 4, pixel size, buffer)
            %else
        {      display font(font num(f))
        {      print string(" --- (not actually loaded)."); newline
               pixel base = -1
            %finish
            buffer == byte integer(addr(char dir) +16*width ptr)
            read region(ref, pixel size+4, (512+5)*4, buffer)
            pixel size = pixel size//4
            deaccess file(ref)
            %true
         %end   { block load info }
   
         %predicate IN PXL(%integer z)
   
            %constant %integer chars = 128
            %integer k, wp, alpha, beta, pixel, in width
            %record (char info) %name this
   
            alpha = 16*z; beta = 4
            %while z >= 1<<23 %cycle
               z = z>>1
               beta = beta - 1
            %repeat
   
            %if width ptr + chars > max widths %start
               %if control flag(error flag + fonts flag) %start
                  display font(font num(f))
                  print string ("---not loaded, DVItype needs larger width table")
                  newline
               %finish
               %false
            %finish
            wp = width ptr + chars
            tfm check sum = integer(addr(char dir)+16*wp)
            %for k=width ptr,1,wp-1 %cycle
               this == char dir(k)
               in width = (((z*this_b3)>>8 + z*this_b2)>>8 + z*this_b1)>> beta
               %if this_b0 # 0 %start
                  -> bad tfm %unless this_b0 = 255
                  in width = in width-alpha
               %finish
               %if this_load=0 %start
                  %if control flag(debug flag) %start
                     print string("Warning - null metric:")
                     write(font num(f),5);write(k-width ptr,4);newline
                  %finish
                  width(k)= 0          { 1<<22-1 !!!!!!!!!!!!!!!!!!!!!!!?
                  pixel width(k) =0
               %else
                  width(k)=in width
                  pixel width(k)=int(conv*width(k))
               %finish
               %if pixel base<0 %then this_load=-1 %elsec
                  this_load = this_file*4 + pixel base-4
            %repeat
            width ptr = wp
            %true
         bad tfm:
             %if control flag(error flag + fonts flag) %start
                display font(font num(f))
                print string("---not loaded, PXL file is bad"); newline
                %if control flag(debug flag) %start
                   write(k,3);printstring(": ")
                   write(char dir(k)_pwidth,0);printsymbol('x');write(char dir(k)_pheight,0)
                   print string(" + ")
                   write(char dir(k)_x offset,0);print symbol('x')
                   write(char dir(k)_y offset,0); print string(" @ ")
                   write(char dir(k)_file,0); print string("; ")
                   write(char dir(k)_b0,0); print string(", ")
                   write(char dir(k)_b1,0); print string(", ")
                   write(char dir(k)_b2,0); print string(", ")
                   write(char dir(k)_b3,0); newline
                %finish
            %finish
            %false
         %end   { in pxl }
   
   
         { Start of define fonts }
         width ptr=0
         %for f=0,1,nf-1 %cycle
            q = font scaled size(f)
            d = font design size(f)
            c = font checksum(f)
            name=font name(f)
            current file name = root.font directory(f).sep sym. name.fil typ
            %unless block load info(current file name) %start
               %if control flag(error flag + fonts flag) %start
                  display font(font num(f))
                  print string("---not loaded, PXL file can't be opened!")
                  newline
               %finish
            %else %if in pxl(q)
               %if control flag(error flag + fonts flag) %start
                  %if c#0 %and tfm check sum#0 %and c#tfm check sum %start
                     display font(font num(f))
                     print string("---beware: check sums do not agree")
                     newline
                     print string("     ("); write(c,1); print string(" vs. ")
                     write(tfm check sum,1); print symbol(')')
                     newline
                  %finish
               %finish
               %if control flag(fonts flag) %start
                  display font(font num(f))
                  print string("---loaded at size "); write(q,1)
                  print string(" DVI units; (");
                  write(4*pixel size,1); print string(" bytes)")
                  newline
               %finish
            %finish
         %repeat
         width(c) = invalid width %for c=nf*128,1,max fonts*128 {invalid fonts}
         pixel width(c) = 0       %for c=nf*128,1,max fonts*128 {invalid chars}
      %end   { define fonts }
   

      %routine READ IN PAGE
   
         %predicate DO PAGE

            %integer a,o,p,q,k, bad char, cur font,s
            %switch option (128:255)
   
            %constant %integer max drift = 2
            %integer hhh
   
            %integer %array h stack,
                            v stack,
                            w stack,
                            x stack,
                            y stack,
                            z stack,
                            hh stack,
                            vv stack (0:stack size)
   
            %on %event 15 %start
               print symbol('!')
               newline
               %false
            %finish
   
            %routine ASSIGN(%integer from, %integer %name to)

              to = from
            %end   { assign }

            %routine ABORTION(%string(127) reason)

               print string(reason)
               new line
               %signal %event 15
            %end   { abortion }

            %routine OVERFLOW(%string(31) name, %integer value)

               print string("DVItype capacity exceeded (")
               print string(name)
               print symbol('=')
               write(value,1)
               print string(")!")
               new line
               %signal %event 15
            %end   { overflow }
   
            %routine OUT TEXT(%integer c,f,x,y)

               char dir(f*128+c)_reqd = 0
               store(stored)_type=-1
               store(stored)_code=128*f+c
               store(stored)_x=x
               store(stored)_y=y
               stored = stored+1
            %end   { out text }
   
            %routine OUT RULE(%integer dx,dy,x,y)

               %return %if dx<=0 %or dy<=0
               store(stored)_type= dx
               store(stored)_code=-dy
               store(stored)_x=x
               store(stored)_y=y
               stored = stored+1
            %end   { out rule }
   
            %routine SHOW(%string (255) text, %integer which, value)

               print symbol('@'); write(a,1); print string(": ")
               print string(text)
               write(which,1) %unless which = no parm
               space %and write(value,1) %unless value = no parm
               newline
            %end   { show }
   
            %integer %function PIXEL ROUND(%integer px)

               %result = int(conv * float(px))
            %end   { pixel round }
   
            %integer %function RULE PIXELS(%integer x)

               %integer n
               n = int(conv*x)
               %result=n
            %end   { rule pixels }
   
   
            { Start of do page }
            cur font = nf
            s=0; h=0; v=0; w=42; x=0; y=0; z=0; hh=0; vv=0
            stored = 0
   
            %cycle
               a = cur loc
               o = get byte
               p = first par(o)
               -> fin set %if o<128
               -> option(o)
               
               !  set 1,2,3,4
               option(128):
               option(129):
               option(130):
               option(131):    -> fin set
               
               !  set rule
               option(132):    -> fin rule
               
               !  put 1,2,3,4
               option(133):
               option(134):
               option(135):
               option(136):    -> fin set
               
               !  put rule
               option(137):    -> fin rule
               
               !  nop
               option(138):    -> done
               
               !  bop
               option(139):   show("bop occured before eop", no parm, no parm); %false
               
               !  eop
               option(140):
                  show("stack not empty at end of page!", no parm, s) %unless s=0
                  %true
               
               !  push
               option(141):
                  overflow("stack size", stack size) %if s = stack size
                  hstack(s)=h; vstack(s)=v; wstack(s)=w; hhstack(s)=hh
                  xstack(s)=x; ystack(s)=y; zstack(s)=z; vvstack(s)=vv
                  s=s+1
                  -> show state
               
               !  pull
               option(142):
                  %if s=0 %start
                     show("(illegal at level zero)!", no parm, no parm)
                  %else
                     s=s-1
                     hh=hhstack(s); h=hstack(s); w=wstack(s); x=xstack(s)
                     vv=vvstack(s); v=vstack(s); y=ystack(s); z=zstack(s)
                  %finish
                  -> show state
               
               !  right 1,2,3,4
               option(143):
               option(144):
               option(145):
               option(146):    -> move right
               
               !  w0,1,2,3,4
               option(147):
               option(148):
               option(149):
               option(150):
               option(151):   assign(p,w)
                              -> move right
               
               !  x0,1,2,3,4
               option(152):
               option(153):
               option(154):
               option(155):
               option(156):   assign(p,x)
                               -> move right
               
               !  down 1,2,3,4
               option(157):
               option(158):
               option(159):
               option(160):    -> move down
               
               !  y0,1,2,3,4
               option(161):
               option(162):
               option(163):
               option(164):
               option(165):   assign(p,y)
                              -> move down
               
               !  z0,1,2,3,4
               option(166):
               option(167):
               option(168):
               option(169):
               option(170):   assign(p,z) 
                              -> move down
               
               ! fnt num 0..63
               option(171):option(172):option(173):option(174):option(175):option(176):
               option(177):option(178):option(179):option(180):option(181):option(182):
               option(183):option(184):option(185):option(186):option(187):option(188):
               option(189):option(190):option(191):option(192):option(193):option(194):
               option(195):option(196):option(197):option(198):option(199):option(200):
               option(201):option(202):option(203):option(204):option(205):option(206):
               option(207):option(208):option(209):option(210):option(211):option(212):
               option(213):option(214):option(215):option(216):option(217):option(218):
               option(219):option(220):option(221):option(222):option(223):option(224):
               option(225):option(226):option(227):option(228):option(229):option(230):
               option(231):option(232):option(233):option(234):          -> change font
               
               ! fnt 1,2,3,4
               option(235):
               option(236):
               option(237):
               option(238):   -> change font
               
               ! xxx special
               option(239):
               option(240):
               option(241):
               option(242):
                  print string ("xxx'")
                  bad char = false
                  %for k=1,1,p %cycle
                     q = get byte
                     %if ' ' <= q <= '~' %start
                        print symbol(q)
                     %else
                        bad char = true
                     %finish
                  %repeat
                  print symbol('''')
                  show("non-ASCII character in xxx command!", no parm, no parm) %if bad char=true
                  -> done
               
               ! fnt def 1,2,3,4
               option(243):
               option(244):
               option(245):
               option(246):   skip font; -> change font
               
               !  pre
               option(247):   abortion("preamble command within a page")
               
               !  post, post post
               option(248):
               option(249):   abortion("postamble command within page!")
               
               option(*):     show("undefined command ",o, no parm); -> done
   
         fin set:
               %if 0 <= p <= 127 %start
                  q = width(128*cur font + p)
               %else
                  q = invalid width
               %finish
               %if q = invalid width %start
                  print symbol('@'); write(a,4); print string(": character")
                  write(p,1)
                  print string(" invalid in font ")
                  print font(cur font)
                  print symbol ('!') %unless cur font = nf
                  newline
               %else
                  out text (p, cur font, doc left margin+hh, doc top margin+vv)
               %finish
               -> done %if o >= 133
               q=0 %if q = invalid width
               hh = hh + pixel width(128*cur font + p)
               -> check right
   
         fin rule:
               q = signed quad
               out rule(rule pixels(q),rule pixels(p),
                                           doc left margin+hh,doc top margin+vv)
               -> done %if o=137
               hh = hh + rule pixels(q)
               -> check right
   
         move right:
               %if p >= font space(cur font) %c
               %or p <= -4*font space(cur font) %start
                  hh = pixel round (h+p)
               %else
                  hh = hh + pixel round(p)
               %finish
               q = p
         check right:
               hhh = pixel round(h+q)
               %if |hhh-hh| > max drift %start
                 %if hhh > hh %then hh = hhh-max drift %elsec
                                    hh = hhh+max drift
               %finish
               h = h+q
               -> done
   
         move down:
               %if |p| >= 5*font space(cur font) %start
                  vv = pixel round(v+p)
               %else
                  vv = vv + pixel round(p)
               %finish
               v = v+p
               -> done
   
         show state:
               -> done
   
         change font:
               font num(nf)=p; cur font=0
               cur font = cur font+1 %while font num(cur font)#p
               -> done
   
         done:
            %repeat
         %end   { do page }
   

         %routine ENSURE FONT LOADING
   
            %integer %function HEAP GRAB(%integer bytes)

               %own %integer kill=0
               %integer address, dead
               %record (char info) %name corpse
   
               %on %event 2 %start
                  dead=kill
                  %cycle
                     kill=0 %if kill >= nf*128
                     corpse == char dir(kill)
                     kill = kill+1
                     %signal %event 2 %if kill=dead
                  %repeat %until corpse_reqd=255 %and corpse_load>0
                  heap put (corpse_load)
                  corpse_load = -1
               %finish
   
               address = heap get(bytes)
               %result = address
            %end   { heap grab }
   
            %integer char, mem, f, ref
            %byte %integer %name buffer
            %string(63) file
            %record (char info) %name this
   
   
            { Start of ensure font loading }
            %if control flag(phase flag) %start
               print string("Loading fonts"); newline
            %finish
            %for char=0,1,nf*128-1 %cycle
               this == char dir(char)
               %if this_reqd=0 %and this_load<0 %start
                  mem = ((this_pwidth+31)//32)*4*this_pheight
                  this_load = heap grab(mem)
                  f = char//128
                  file = root.font directory(f).sep sym.font name(f).fil typ
                  %if exists(file) %start
                     buffer == byte integer(this_load)
                     access file(file, 0, ref, f)
                     read region(ref, this_file*4, mem, buffer)
                     deaccess file(ref)
                  %else
                     abort(" --- file '".file."' has disappeared!")
                  %finish
               %finish
            %repeat
            %if control flag(phase flag) %start
               print string("Fonts loaded"); new line
            %finish
         %end   { ensure font loading }
   
   
         { Start of read in page }
         %if loading = dynamic %start
            char dir(k)_reqd=255 %for k=0,1,nf*128-1
         %finish
         %if control flag(info flag + pages flag) %start
            newline
            write(cur loc-45,1)
            print string(": beginning of page ")
            %for k=0,1,9 %cycle
               write(count(current page, k),1)
               print symbol('.') %unless k=9
            %repeat
            new line
         %finish
         bad dvi("page ended unexpectedly") %unless do page
         ensure font loading %if loading = dynamic
         %if control flag(info flag) %start
            write(stored,1); print string(" characters/rulers stored.")
            newline
         %finish
      %end   { read in page }
   
   
      %routine MOVE TO PAGE(%integer p)

         cur loc = page pointer(p)+45
         set input(cur loc)
      %end   { move to page }
   
   
      %routine PAINT

         %integer symbol
         %record (entry) %name item
 
         %routine PAINT CHAR(%integer c,x,y)

            %constant %integer bytes per line = 320, {2560 bits}
                               x max = 2560,         {2400 ?}
                               y max = 3500          {for 3600?}
 
            %integer x0, y0, clip left, clip right, xxxxx,
                     p, bp, ptr, pntr,
                     w, lw, line, word, shift, h
 
            %byte %integer %name frame pontr
            %record (char info) %name char data
 
            char data == char dir(c)
            frame pontr == frame(0)
 
            w = char data_p width
            h = char data_p height
            bp= char data_load
            %if bp<0 %start
               print string("character not loaded => not printed");newline
               %return
            %finish
            x0= x - char data_x offset
            y0= y - char data_y offset
            x = x0 + w - 1
            y = y0 + h - 1
            clip left = 0
            clip right= 0
            lw= ((w+31)>>5)*4
 
            %unless x<0 %or x0 >= x max %orc
                    y<0 %or y0 >= y max %start
 
               %if y0<0 %start
                  h = h+y0
                  bp= bp - y0*lw
                  y0= 0
               %finish
 
               %if y>= y max %start
                  h = h + y max - y -1
               %finish
 
               %if x>= x max %start
                  w = w + x max - x -1
                  clip right = 1
               %finish
 
               x = x0
                %if x0<0 %start
                  x0= ((-x0)>>4)*2
                  bp= bp + x0
                  w = w - x0*8
                  clip left = 1
                  x0 = 0
               %finish
 
               pntr = addr(frame) + (x0>>4)*2 + y0*bytes per line
               x0 = x & 15
               shift = 16 - x0
               w = (w-1)>>4 - clip left - clip right
 
               %for line = 1,1,h %cycle
                  p = bp
                  ptr = pntr
 
                  %if clip left#0 %start
                     half integer(ptr) = half integer(ptr) %c
                                       ! (half integer(p)<<shift)&16_FFff
                     p = p+2
                  %finish
 
 
             *move.l   ptr,a1
             *move.l   p,a0
             *move.l   shift,d1
             *move.l   w,d2
             *bmi      #16
             *moveq    #0,d0
             *move.w   (a0)+,d0
             *lsl.l    d1,d0
             *or.l     d0,(a1)
             *addq     #2,a1
             *dbra     d2,#-12
             *nop
             *nop
             *nop
 
                  bp = bp + lw
                  pntr = pntr + bytes per line
               %repeat
            %finish
         %end   { paint char }
 
         %routine PAINT RULER(%integer dx,dy,x,y)

            %constant %short bytes per line = 320, {2560 bits}
                             x max = 2560,         {2400 ?}
                             y max = 3500          {for 3600?}
 
            %label bigx, bigy, weex, weey, iloop, oloop, last, invisible
            %integer regd4, regd5
            %short xdisp, ydisp; xdisp=0; ydisp=0
 
             *move.l    d4,regd4
             *move.l    d5,regd5
             *move.l    x,d2
             *move.l    y,d1
             *move.l    dx,d0
             *bmi       invisible
             *beq       invisible
             *move.l    dy,d3
             *neg.l     d3
             *bgt       invisible
             *add.w     d2,d0
             *add.l     d1,d3
             *sub.w     xdisp,d2
             *bpl       bigx
             *moveq     #0,d2
 bigx:       *sub.w     ydisp,d3
             *bpl       bigy
             *moveq     #0,d3
 bigy:       *sub.w     xdisp,d0
             *bmi       invisible
             *sub.w     ydisp,d1
             *bmi       invisible
             *cmp.w     #xmax,d2
             *bpl       invisible
             *cmp.w     #ymax,d3
             *bpl       invisible
             *cmp.w     #xmax,d0
             *bmi       weex
             *move.w    #xmax-1,d0
 weex:       *cmp.w     #ymax,d1
             *bmi       weey
             *move.w    #ymax-1,d1
 weey:       *sub.w     d3,d1
             *mulu      #bytesperline,d3
             *movea.l   frame,a3
             *adda.l    d3,a3
             *moveq     #-1,d3
             *moveq     #31,d4
             *and.w     d2,d4
             *lsr.w     #5,d2
             *lsr.l     d4,d3
             *moveq     #31,d4
             *and.w     d0,d4
             *lsr.w     #5,d0
             *sub.w     d2,d0
             *subq.w    #1,d0
             *lsl.w     #2,d2
             *adda.w    d2,a3
             *moveq     #1,d2
             *ror.l     #1,d2
             *asr.l     d4,d2
 oloop:      *movea.l   a3,a2
             *move.l    d3,d5
             *move.w    d0,d4
             *bmi       last
 iloop:      *or.l      d5,(a2)+
             *moveq     #-1,d5
             *dbra      d4,iloop
 last:       *and.l     d2,d5
             *or.l      d5,(a2)
             *add.w     #bytesperline,a3
             *dbra      d1,oloop
 invisible:  *move.l    regd4,d4
             *move.l    regd5,d5
        %end   { paint ruler }
 
        reset frame
        %for symbol=0,1,stored-1 %cycle
           item == store(symbol)
           %if item_type<0 %then paint char (item_code, item_x, item_y) %c
                %else paint ruler(item_type, -item_code, item_x, item_y)
        %repeat
     %end   { paint }
 
 
     %routine PRINT SHEET

       %if copies reqd (current page) > 0 %start
          move to page(current page)
          read in page
          paint
          %if control flag(pause flag) %start
             select input(0); prompt("Press return when ready: ")
             read symbol(copy) %until copy=nl
             select input(dvi channel)
          %finish
          %if control flag(info flag ! pages flag) %start
             print string("Printing"); write(copies reqd(current page),1)
             %if copies reqd(current page) = 1 %start
                print string (" copy.")
             %else
                print string(" copies.")
             %finish
             newline
          %finish
          print page %for copy=1,1,copies reqd(current page)
          print symbol('.') %for copy=1,1,copies reqd(current page)
        %finish
     %end   { print sheet }
 
 
     %routine PRINT PAGES(%integer from, step, to, mode)

        %integer page, copy
        %for page = from, step, to %cycle
           current page = page
           print sheet %if output mode(current page)=mode
        %repeat
     %end   { print pages }

 
     %integer %function FIND PAGE(%integer mode)
   
       %if mode = 1 %then %start
         %while copies reqd(my current page)=0 %and my current page#total pages %cycle
           my current page = my current page+1
         %repeat
         %result = my current page
       %finish
 
       %if mode = 0 %then %start
         %while my current page#total pages+1 %and copies reqd(my current page)>=1 %cycle
           copies reqd(my current page)=1
           my current page = my current page+1
         %repeat
         %result = my current page-1
       %finish
       %result = my current page { dummy }
     %end   { find page }

{******************************************************************************}
{******************************************************************************}

!     open append(1,"tex:spdebug")
!     select output(1)
!     printstring("At start of main program freestore = ")
!     write(freestore,0);newline
!     close output
!     select output(0)

     %if pixel space*4+safety margin > free store %c
     %or control flag(dyn ld flag) %then loading = dynamic %c
                                   %else loading = static
     %if control flag(info flag + fonts flag) %start
        %if control flag(fonts flag) %start
           write(pixel space*4,0);print symbol('+');write(safety margin,0)
           print string(" vs."); write(free store,0);newline
        %finish
        %if loading=dynamic %start
           print string("(dynamically")
        %else
           print string("(statically")
        %finish
        print string(" loading fonts)."); newline
     %finish

     %if control flag(phase flag) %start
        print string("Pre-reading page numbers"); newline
     %finish
     pass bops setting count
     %if control flag(phase flag) %start
        print string("Defining fonts"); newline
     %finish
     define fonts
     %if control flag(phase flag) %start
        print string("Fonts defined"); new line
     %finish

     %if print sets = "" %start
        copies reqd(current page) = copies %for current page =1,1,total pages
     %else
        %begin   { 4 }
           %string(255) part range, print set
        
           %routine setup range(%string(255) range)
        
              %string(255) number
              %integer do, first, last, page
        
              %integer %function decode(%string(255) text, %integer low, high)
                  %integer acc, sign, sym
        
                  %on %event 1,2,3,4,5,6,7,8,9,10 %start
                     %if control flag(error flag ! info flag) %start
                        print string("*** ")
                        print string(text)
                        print string(": not a valid integer; zero substituted.")
                        newline
                     %finish
                     %result = 0
                  %finish
        
                  %if text -> ("-").text %start
                     sign = -1
                  %else
                     sign = 1
                  %finish
        
                  acc=0
                  %signal %event 9 %if text = ""
                  %for sym = 1, 1, length(text) %cycle
                     %signal %event 9 %unless '0' <= charno(text,sym) <= '9'
                     acc = acc*10 + charno(text, sym) - '0'
                  %repeat
        
                  acc = acc * sign
                  %signal %event 9 %unless low <= acc <= high
                  %result = acc
              %end   { decode }
        
              %integer %function page number(%string(255) text)
                 %constant %integer minus infinity = \((-1)>>1),
                                    plus  infinity =   (-1)>>1
                 %integer %array cnts(0:9)
                 %integer cnt, inst, i,j
                 %string(255) page

                 %if text = "$" %start
                    %result = total pages
                 %else %if text -> ("#").text
                    %result = decode(text, minus infinity, plus infinity)
                 %else
                    %if text -> text.("#").page %start
                       inst = decode(page, 1, plus infinity)
                    %else
                       inst = 1
                    %finish
                    cnt=-1
                    %while text -> page.(".").text %cycle
                       %unless cnt=9 %start
                          cnt = cnt + 1
                          cnts (cnt) = decode (page, minus infinity, plus infinity)
                       %finish
                    %repeat
                    %unless cnt=9 %start
                       cnt = cnt + 1
                       cnts (cnt) = decode (text, minus infinity, plus infinity)
                    %finish
                    
                    %for i=1,1,total pages %cycle
                       %for j=0,1,cnt %cycle
                          %exit %if cnts(j) # count(i,j)
                          inst = inst-1 %if j=cnt
                       %repeat
                       %result = i %if inst = 0
                    %repeat
                    %result = total pages
                 %finish
              %end   { page number }
        
              { Start of setup range }
              %if range # "" %start
                 %if range -> range.("*").number %start
                    do = decode(number, 0, 255)
                 %else
                    do = copies
                 %finish
        
                 %if range -> range.(":").number %start
                    first = page number(range)
                    last  = page number(number)
                 %else
                    first = page number(range)
                    last  = first
                 %finish
        
                 %if last >= first %start
                    copies reqd(page) = do %for page=first,1,last
                 %finish
              %finish
           %end   { setup range }
     
           copies reqd(current page) =0 %for current page=1,1,total pages

           %while print sets -> print set.(" ").print sets %cycle
              %while print set -> part range.(",").print set %cycle
                 set up range(part range)
              %repeat
              set up range(print set)
           %repeat
           %while print sets -> part range.(",").print sets %cycle
              set up range(part range)
           %repeat
           set up range(print sets)
        %end   { 4 }
     %finish

     %if control flag(backd flag) %start
       my current page = 1
       %cycle
         start double = find page(1)
         end double = find page(0)
         output mode(end double)=0
         output mode flag = 0
         double page = start double 
         %while double page < end double %cycle
           %if |count(double page,0) - count(double page+1,0)| < 2 %start
               output mode(double page)=1
               double page = double page+1
               output mode(double page)=2
               output mode flag = 1
            %else
              output mode(double page)=0
            %finish
            double page = double page+1
         %repeat
         %unless output mode flag=0 %start
           print pages(1,  1, end double, 2)
           select input(0); prompt("Transfer pages, press return when ready: ")
           read symbol(copy) %until copy=nl
           select input(dvi channel)
           print pages(end double, -1, start double, 1)
         %finish
         print pages(end double, -1, start double, 0)
       %repeat %until my current page >= total pages
     %else
        print sheet %for current page=total pages,-1,1
     %finish
     %end   { 3 }
   %end   { 2 }
   jump out:
   reset frame

!   open append(1,"tex:spdebug")
!   select output(1)
!   printstring("At very end freestore = ")
!   write(freestore,0); newline
!   close output
!   select output(0)

%end   { print dvi file }