%option "-nocheck-nodiag-half-low-nons"
%conststring version = "Canon Laserprinter Driver Version 2.93"
!      Hamish Dewar  1984, Duncan Baillie 1985
! 2.3: Renamed Hamish's release and mark so I can use the proper
!      mark and release for heap management. Also taken all the
!      pseudo compiler directives out.
! 2.4: Attempts to use MARK and RELEASE
!      Grabs a wee bit more heap than needed (but MARK & RELEASE work now)
! 2.5: Includes sethost to log onto text and quotes password on lp1: to 
!      gain access to files. Logs all files printed to test:.laserdb
! 2.6: New global variable 'pagesprinted' keeps count of number of pages
!      printed from each file and adds them to the end of the database.
! 2.7: Improved comms to stop bit dropout on laserprinter
! 2.8: Changed use of SETHOST stuff to economise on filestore ports.
!      (This involved changes to the SETHOST file as well) - RWT.
!      Also removed silencing of PTM - disabling interrupts is enough.
!2.91: Fixed bug - when paragraph started at foot of page, such that required
!      number of lines causes page break, paragraph didn't get indented - JG.
!2.92: Fixed bug caused by logging before deleting (non-one ever deletes the log
!      file, so it gets huge and fragmented, giving "no quota" or "no extents"
!      error when trying to extend it, that failure prevented the program
!      from deleting the file just printed, causing looping). - RWT
!2.92a:Disconnecting discontinued - RWT
!2.93: Fixed bug which caused PLAIN printing to lose stuff - RWT.

{ Third attempt at solution: Has 'frame' declared as
{ %externalbyteintegerarraynamespec.
%include "INC:UTIL.IMP"
%include "inc:region.imp"
%include "inc:fs.imp"
%include "inc:fsutil.imp"
%include "text:sethost-nowarn"

%begin;  

!Ascii characters:
%constinteger RT=13, LF=10, BEL=7, SUB=26, ESC=27
%constinteger BS=8, FF=12
%constinteger CASEBIT=32, LETMASK=95

%constinteger UNITY=256, HALF=128
%constinteger DEFAULTFACTOR=4
%own%integer FACTOR=defaultfactor,FAC2=(defaultfactor+1)//2;  !for graphics

!Input file buffering:
%integer SYM,INSYM
%constinteger SMAX=4095;  !must be power of 2 minus one
%byteintegerarray SOURCE(0:smax)
%own%integer SPOS=0,SLIM=0,SOURCELINESTART=0
!
!Macro storage
%constinteger MACBOUND=1000
%byteintegerarray MAC(1:macbound)
%integerarray MACSTACK(0:32)
%constinteger MACMASK=15
%constinteger LETSYM=-2
%shortarray DEF(0:255)
%constinteger TEXTBOUND=1000
%byteintegerarray NCHAR(1:textbound)
%integer MSP,ALTMSP,MACPOS,MACFREE,NAMEFREE
!
%string(255) FNAME,GNAME,temp1,temp2
%constinteger MAXSPOOLFILES=20;  !ie how many names it is reasonable
                                 ! to store
%string(31)%array SPOOLED(1:maxspoolfiles)
%own%integer ROGUEFILES=0
%own%integer SPOOLFILES=0
%own%integer CURIN=0
%string(63) host string
%integer COPIES, host token, pagesprinted

!!!!!!!!!!!!!!!!!!!!!!!!  Utility procedures  !!!!!!!!!!!!!!!!!!!!!!!!!!!

%routine REPORT(%string(255) s, %integer v)
  printstring(s);  write(v,0)
%end

%routine CROAK(%string(255) s)
  printstring(s);  newline
  %signal 3
%end

%routine PHEX4(%integer v)
%integer i,k
  %for i = 12,-4,0 %cycle
    k = v>>i&15;  k = k+7 %if k > 9
    printsymbol(k+'0')
  %repeat
%end

%integer LBASE,LLIM,RBASE
%integer RFONTS=0, TFONTS=0

!!Font storage etc (Auxiliary stack)
%integer STOREMIN,STORELIM,STOREFREE,RESLIM
!
%routine INITIALISE STORE
%integer k
  k = freestore&(\3)
  storemin = heapget(k-1000000);  !allow for working space
  storelim = storemin+k
!  *move d6,storemin;  !lower store bound
!  *move sp,d6;        !upper store bound
!  *sub #-3000,d6;     !allow for stack expansion
!  *move d6,storelim
!  storelim = storelim-256
  croak("Insufficient store") %if storelim <= storemin
  storefree = storemin;  reslim = storemin
%end
!
%record(*)%map NEWCELL(%integer size)
  size = (size+11)&(\3);  !multiple of 4 + 4 plus 4 for luck
  integer(storefree) = size
  storefree = storefree+size
  croak("Heap exhausted") %if storefree > storelim
  %result == record(storefree-size+4)
%end
!
%routine hmd release(%record(*)%name p)
%integer q
  q = addr(p)-4
  %return %if q <= reslim
!  croak("Heap corrupt") %if integer(q) <= 0
  storefree = q %if q+integer(q) = storefree
%end

%predicate OPENED(%string(255) name)
  %on %event 3,9 %start
    select input(curin)
    printstring(event_message);  newline
    %false
  %finish
  printstring("Opening ".name);  newline
  open input(curin+1,name)
  curin = curin+1
  select input(curin)
  %true
%end

%routine GET SYM
  %if spos < slim %start
    insym = source(spos&smax)
  %else
    read symbol(insym)
    source(slim&smax) = insym;  slim = slim+1
  %finish
  sym = insym;  spos = spos+1
%end

%routine SWOP(%integername a,b)
%integer i
  i = a;  a = b;  b = i
%end

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

!%externalroutinespec CONNECT FILE(%string(255) f,%integer mode,
!                                  %integername start,len)

!Vector fonts
%recordformat XYINFO(%byte x,y)
%recordformat VCHARI(%byte xbias,xmax,ybias,ymax,
                     %record(xyinfo)%array XY(1:1000{nominal}))
!Raster fonts
%recordformat RASTI(%short width,xbias,xmax,ybias,ymax,
                    %shortarray pattern(1:1000{nominal}))
%constinteger RASTHEADLEN=10
!Basic fonts
%recordformat BFONTINFO(%integer len,
                        %integer name1,name2,
                        %short type,
                        %bytearray spare(1:12),
                        %short width,
                        %short scale,
                        %byte ybias,ymax,
     (%short%array base(0:127) %or %record(rasti)%name%array absbase(0:127)))
%constinteger BFBOUND=64
%record(bfontinfo)%name%array BINDEX(0:bfbound)
!Derived fonts
%recordformat CHARI(%record(rasti)%name raster, %short scale,
                    %byte bfont,bchar)
!BFONT flagged to indicate orientation
%recordformat DFONTINFO(%short ymax,ybias,width,spare,
                        %record(chari)%array char(32:127))
%constinteger DFBOUND=63
%record(dfontinfo)%name%array DINDEX(0:dfbound)

!LAYOUT parameters
%constinteger TAB0=28;  !number of parameters (vector TAB last)
%constinteger LEFTNAME=tab0-4;  !preceded by 4 horizontal measures
%constinteger TOPNAME=leftname-4;  !preceded by 4 vertical measures
%constinteger UNAME=topname-4, HNAME=uname+1, DNAME=hname+2
%constinteger FONAME=uname-1, INAME=foname-1
!
%constinteger TABBOUND=25, PARMBOUND=tab0+tabbound
![See RESET PARAMETERS for actual intialisation]
%owninteger NUM=0
%owninteger ESCAPE='$'
%owninteger CAP=0, CAPSH=0
%owninteger INVERT=0
%owninteger ASCII=1, JUST=0, HMDMARK=0, IGNORE=0
%owninteger START=1, FINISH=9999
%owninteger PAGENO=0, SECTNO=0
%owninteger MODE=0
%owninteger INDENT=0
%owninteger FONT=0,UNDER,BOLD,SLANT,DISP
%owninteger TOP=2, BOTTOM=4, PAGE=60, NLS=1
%owninteger LEFT=0, LINE=72, SGAP=2, PGAP=3
%ownintegerarray TAB(0:tabbound)= %c
  0, 8, 16, 24, 32, 48, 56, 64,
  72, 80 (*)

%integer FONTYBIAS, FONTYMAX, FONTYDISP, FONTWIDTH
%record(dfontinfo)%name FBASE
%integer ROT, PENWIDTH {, VLIMIT, HLIMIT
%integer VERPOS, HORPOS, CHARSIZE
%integer LINEYBIAS, LINEYDISP, LINEHEIGHT, SPACEWIDTH

%routine SELECT FONT(%integer f)
!printstring("Selecting");write(f,1)
  f = 0 %if dindex(f) == nil
!write(f,1);newline
  font = f;  fbase == dindex(font)
  fontwidth = fbase_width;  spacewidth = |fontwidth|
  fontybias = fbase_ybias
  fontymax = fbase_ymax
  fontydisp = fontymax-fontybias
!report("Font:",f)
!report(" width:",fontwidth)
!report(" ybias:",fontybias)
!report(" ymax:",fontymax)
%end

%routine FETCH LINE FONTS
!Pre-defined line fonts (in store-map form)
%integer f,q,pos,fonts
%conststring(13) LINEFONTS="DOC:GIMMS.BIN"
  %on %event 3 %start
    printline(event_message)
    %return
  %finish
  bindex(f) == nil %for f = 0,1,bfbound
  connect file(linefonts,0,lbase,q)
  fonts = 0;  pos = lbase
  %cycle
    q = integer(pos)
    %exit %if q = 0
    %if integer(pos+q-4) # q %start
      printstring("** Inconsistency at font:");  write(fonts+1,1)
      newline
      %exit
    %finish
    fonts = fonts+1
!printsymbol(byteinteger(pos+f)) %for f = 4,1,11
!report(" width:",shortinteger(pos+26))
!report(" scale:",shortinteger(pos+28))
!report(" ybias:",byteinteger(pos+30))
!report(" ymax:",byteinteger(pos+31))
!newline
   !Gimms number
    f = (byteinteger(pos+10)-'0')*10+byteinteger(pos+11)-'0'
    bindex(f) == record(pos)
    pos = pos+q
  %repeat
  report("Line fonts:",fonts)
  report("  Bytes:",pos-lbase)
  newline
  %stop %if fonts = 0
%end;  !FETCH LINE FONTS

%routine FETCH RASTER FONTS
%integer j
!Pre-defined raster fonts
%conststring(14) RASTERFONTS="DOC:RFONTS.BIN"
  %on %event 3 %start
    printline(event_message)
    %return
  %finish
  connect file(rasterfonts,0,rbase,j)
%end

%record(vchari)%map VCHARVEC(%record(bfontinfo)%name B, %integer char)
  %result == nil %if b_base(char) = 0
  %result == record(b_base(char)+addr(b_base(0)))
%end

%record(rasti)%map RCHARVEC(%record(bfontinfo)%name B, %integer char)
  %result == b_absbase(char)
%end

%integerfn NEW BASIC FONT(%integer type,ymax,ybias,width,n1,n2)
%integer i,j
%record(bfontinfo)%name B
  j = 0
  %for i = 1,1,bfbound %cycle
    b == bindex(i)
    %if b == nil %start
      j = i
    %else %if b_name1 = n1 %and b_name2 = n2
      hmd release(b_absbase(j)) %for j = 127,-1,33
      j = i
      %exit
    %finish
    b == nil
  %repeat
  %if j = 0 %start
    printline("**No basic font numbers left")
    %result = 0
  %finish
  b == newcell(sizeof(b)) %if b == nil
  b = 0
  b_type = type;  b_ymax = ymax;
  b_ybias = ybias;  b_width = width
  b_name1 = n1;  b_name2 = n2
  bindex(j) == b
  %result = j
%end

%routine INITIALISE DERIVED FONT(%integer dfont,ymax,ybias,width)
%integer i,j
%record(dfontinfo)%name d
  %if dindex(dfont) ## nil %start
    d == dindex(dfont)
    %for i = 127,-1,33 %cycle
      j = d_char(i)_bfont&63
      %if j >= rfonts %and bindex(j)_type = 0 %start
        hmd release(d_char(i)_raster)
      %finish
    %repeat
  %else
    d == newcell(sizeof(d))
    dindex(dfont) == d
  %finish
  d_ymax = ymax;  d_ybias = ybias
  d_width = width
  d_char(i) = 0 %for i = 32,1,127
%end

%routine INITIALISE SCALED FONT(%integer dfont,bfont,scale,height,depth,width)
%integer scale2
%record(bfontinfo)%name B
%integerfn scaled(%integer v)
  %result = 0 %if v <= 0
  %result = (v*scale2+half)>>8
%end
  %cycle
    b == bindex(bfont)
    %exit %if b ## nil
    bfont = bfont-1
    %return %if bfont < 0
  %repeat
  scale2 = (b_scale*scale+half)>>8
  height = scaled(b_ymax+1) %if height = 0
  depth = scaled(b_ybias) %if depth = 0
  width = scaled(b_width) %if width = 0
  width = -scaled(vcharvec(b,' ')_xmax+1) %if width = 0
  initialise derived font(dfont,height-1,depth,width)
%end

%routine DEFINE DERIVED CHARS(%integer dfont,bfont,dchar,bchar,num,scale)
%integer i
%record(dfontinfo)%name D
  d == dindex(dfont)
  %for i = 0,1,num-1 %cycle
    d_char(dchar+i)_scale = scale
    d_char(dchar+i)_bfont = bfont
    d_char(dchar+i)_bchar = bchar+i
  %repeat
%end

%routine DEFINE SCALED FONT(%integer dfont,bfont,scale,height,depth,width)
  initialise scaled font(dfont,bfont,scale,height,depth,width)
  define derived chars(dfont,bfont,33,33,95,scale)
%end

%routine INITIALISE RASTER FONTS
%integer J,POS,CHAR,RSIZE
%recordformat FONTINFO(%byte fybias,fymax,fwidth,spare,
                       %bytearray present(4:31))
%record(fontinfo)%name F
%record(dfontinfo)%name D
%record(rasti)%name R

  dindex(j) == nil %for j = 0,1,dfbound
  pos = rbase
  %cycle
    f == record(pos);  pos = pos+sizeof(f)
    initialise derived font(rfonts,f_fymax,f_fybias,f_fwidth)
    d == dindex(rfonts)
    %for char = 32,1,127 %cycle
      %if f_present(char>>3)&(128>>(char&7)) # 0 %start
        r == record(pos-2);  !allow for non-existent WIDTH
        rsize = (r_ymax+1)*(r_xmax>>4+1)*2+(rastheadlen-2)
        pos = pos+rsize
        d_char(char)_raster == r
        d_char(char)_bfont = rfonts+rfonts<<6;  !90o for font 1
        d_char(char)_bchar = char
      %finish
    %repeat
    rfonts = rfonts+1
  %repeat %until rfonts = 2
  printstring("Raster fonts:2  Bytes:");  write(pos-rbase,0);  newline
%end;  !INITIALISE RASTER FONTS
!
%record(rasti)%map TORASTER(%integer bfont,bchar,scale,rot)
%constinteger STEP=half
%integer X,Y,Z,LASTX,LASTY,XX,YY,YBIAS,YMAX,XBIAS,XMAX,
         UYMAX, UXMAX, EXTRA
%integer I,J,RBASE,RSIZE,UNITS,STRIPS
%record(bfontinfo)%name B
%record(vchari)%name VC
%record(xyinfo)%name VCC
%record(rasti)%name R

%routine POINT(%integer X,Y)
%option "-nosass"
  x = (x+half)>>8
  y = (y+half)>>8
  y = ymax-y %if rot # 0
  y = y<<1+rbase
  y = y+strips %and x = x-16 %while x >= 16
  shortinteger(y) <- shortinteger(y)!16_8000>>x
%end
      
%routine LINE(%integer X1,Y1,X2,Y2)
%integer QSTEP=step, DX=|x2-x1|, DY=|y2-y1|
%integer E
  %if dx >= dy %start
    %if x1 > x2 %start
      x1 = x1-dx;  x2 = x2+dx;  !swop
      e = y1;  y1 = y2;  y2 = e
    %finish
    qstep = -qstep %if y1 > y2
    e = dx;  dx = dx+dx;  dy = dy+dy
    %cycle
      point(x1,y1)
      e = e-dy
      %if e < 0 %start
        y1 = y1+qstep;  e = e+dx
      %finish
      x1 = x1+step
    %repeat %until x1 >= x2
  %else
    %if y1 > y2 %start
      y1 = y1-dy;  y2 = y2+dy;  !swop
      e = x1;  x1 = x2;  x2 = e
    %finish
    qstep = -qstep %if x1 > x2
    e = dy;  dy = dy+dy;  dx = dx+dx
    %cycle
      point(x1,y1)
      e = e-dx
      %if e < 0 %start
        x1 = x1+qstep;  e = e+dy
      %finish
      y1 = y1+step
    %repeat %until y1 >= y2
  %finish
  point(x2,y2)
%end
   
%integerfn SCALED(%integer v)
  v = 0 %if v < 0
  %result = (v*scale+half)>>8
%end

  b == bindex(bfont)
  %result == nil %if b == nil
  %if b_type = 1 %start;  !basic font is raster
    %result == rcharvec(b,bchar)
  %finish
  vc == vcharvec(b,bchar)
  %result == nil %if vc == nil
  extra = scale>>8
  scale = (b_scale*scale+half)>>8
  lastx = vc_xbias
  xbias = scaled(vc_xbias)
!  uxmax = vc_xmax
  xmax = scaled(vc_xmax)+extra
  lasty = vc_ybias
  ybias  = scaled(vc_ybias)
!  uymax = vc_ymax
  ymax  = scaled(vc_ymax)+extra
  %if rot # 0 %start
    swop(xbias,ybias);  swop(xmax,ymax)
    ybias = ymax-ybias
    swop(lastx,lasty)
  %finish
  strips = (ymax+1)<<1
  units = xmax>>4+1
  rsize = units*strips+rastheadlen
!write(rsize,1);write(rot,1);write(units,1);write(strips,1);newline
  r == newcell(rsize);  rsize = rsize+addr(r)
  r_width = xmax+1
  r_xbias = xbias;  r_xmax = xmax
  r_ybias = ybias;  r_ymax = ymax
  rbase = addr(r_pattern(1))
!Clear raster:
  i = rbase
  %cycle
    shortinteger(i) = 0
    i = i+2
  %repeat %until i = rsize
!Insert bits:      
  vcc == vc_xy(1)
  lastx = lastx*scale;  lasty = lasty*scale
  %cycle
    x = vcc_x;  y = vcc_y
    xx = (x&127)*scale;  yy = (y&127)*scale
    swop(xx,yy) %if rot # 0
    vcc == vcc[1]
    %if x&128 = 0 %start
      line(lastx,lasty,xx,yy)
%if extra > 0 %start
  i = extra
  %if |lastx-xx| < |lasty-yy| %start
    %cycle
      line(lastx+i,lasty,xx+i,yy)
      i = i-1
    %repeat %until i = 0
  %else
    %cycle
      line(lastx,lasty+i,xx,yy+i)
      i = i-1
    %repeat %until i = 0
  %finish
%finish
    %finish
    lastx = xx;  lasty = yy
  %repeat %until y&128 # 0
!!  %if extra # 0 %start
!write(strips,1);write(units,1);write(rsize-rbase,1);newline
!    i = rbase
!    %cycle
!      j = i;  x = 0
!      %cycle
!        y = shortinteger(j)
!        shortinteger(j) = shortinteger(j)!x
!        x = y;  j = j+2
!      %repeat %until j >= i+strips
!      i = i+strips
!    %repeat %until i >= rsize
!    i = rbase
!    %cycle
!      j = i;  x = 0
!      %cycle
!        y = shortinteger(j)&16_FFFF
!        shortinteger(j) = shortinteger(j)!(x<<15!y>>1)
!        x = y;  j = j+strips
!      %repeat %until j >= rsize
!      i = i+2
!    %repeat %until i >= rbase+strips
!!    i = rbase
!!    %cycle
!!      j = i;  x = 0
!!      %cycle
!!        x = x!shortinteger(j)
!!        y = 0
!!        y = shortinteger(j-strips) %if i > rbase
!!        z = 0
!!        z = shortinteger(j+strips) %if j+strips < rsize
!!        x = x&16_FFFF;  z = z&16_FFFF
!!        x = x ! ((y<<15!x>>1) & (z>>15!x<<1))
!!        x = x ! ((y<<14!x>>2) & (z>>14!x<<2))
!!        shortinteger(j) = x
!!        j = j+2
!!        %exit %if j > i+strips-2
!!        %if j = i+strips-2 %then x = 0 %c
!!        %else x = x&shortinteger(j+2)
!!      %repeat
!!      i = i+strips
!!    %repeat %until i >= rsize
!!  %finish
  %result == r
%end;  !TORASTER
!
!!!!!!!!!!!!!!!!!!!!!!!!!!  Device Control Section  !!!!!!!!!!!!!!!!!!!!!!!!

%constinteger ERASED=-1, FILLING=0, PRINTED=1
%own%integer FRAMESTATE=filling
!Canon LPB-CX dimensions
%constinteger VUPI=300, HUPI=300;  !vertical/horizontal units per inch
%constinteger PRINTHEIGHT=3500, PRINTWIDTH=2352 {v2.93, was 2400}
%constinteger BOLDSTEPS=2
%constinteger CFRAMEHEIGHT=3500,CFRAMEWIDTH=2560
%integer PRINTING=-1
%constinteger FRAMEHEIGHT=3500,FRAMEWIDTH=2560,
              FRAMEMULT=framewidth//8, FRAMEINC=-framemult,
              FRAMESIZE=frameheight*framemult

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

%integer FRAMEBASE1, FRAMEBASE2, FRAMEBASE, FRAMELIM

%routine RESET FRAME
%integer q
 %if framestate # erased %start
  q = framesize
!  p = framebase
!  integer(p) = 0 %and p = p+4 %and q = q-4 %until q = 0
  *move.l framebase,a0
  *move.l q,d1
  *moveq #0,d0
  *move.l d0,(a0)+
  *subq.l #4,d1
  *bgt #-6
%finish
framestate = filling;  !NB rather than ERASED (override if nec)
%end

%routine WAIT
  printing = -1
%end

%routine START PRINTER
@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=80, leftmargin=224 {>= 16}
%integer i
  wait %if printing >= 0
!Lock out timer interrupts
*move.w #16_700,d0; *trap #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
!  *move #15,d2
  *move #(leftmargin//16-1),d2
loop11:
  *move.w d0,prdata
  *dbra d2,loop11
!Data for line
  *move a0,a1
  *move #hcount,d2   {inner loop D2
loop2:
  *move.w cntrstat,d4
  *and.w #fifofull,d4
  *bne loop2
  *move.w (a1)+,prdata
  *dbra d2,loop2
  *move.w #0,prdataeol
  *lea framemult(a0),a0
  *dbra d1,loop1
  printing = -1
  pagesprinted = pagesprinted+1
*move.w #0,d0; *trap #0
%end


%routine PRINT PAGE
%integer c
  %return %if framestate # filling
  framestate = printed
  c = copies
  %cycle
    start printer
    c = c-1
  %repeat %until c <= 0
  wait %if framebase1 = framebase2;  !ie no double-buffering
  %if framebase = framebase1 %then framebase = framebase2 %c
  %else framebase = framebase1
  framelim = framebase+framesize-framemult
%end

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

%routine PLACE(%integer v,h, %record(rasti)%name r)
!Insert bits for character raster addressed by R
! at reference point V,H
%integer cp,fp,shift,xmax,ymax
  %return %if r==nil
  cp = addr(r_pattern(1))
  xmax = r_xmax
  ymax = r_ymax
  v = v+r_ybias
  h = h-r_xbias
  %return %if h < 0 %or h+xmax >= framewidth %c
          %or v >= frameheight %or v-ymax < 0
  fp = framebase+v*framemult+h>>3&(\1)
  shift = (\h)&15
  *move.l xmax,d3
  *move.l ymax,d4
  *move.l cp,a0
  *move.l fp,a1
  *move.l shift,d1
  *lsr.l #4,d3
loop1:
  *move.l d4,d2
  *move.l a1,a2
loop2:
  *moveq #0,d0
  *move.w (a0)+,d0
  *lsl.l d1,d0
  *or.l d0,(a2)
  *lea frameinc(a2),a2
  *dbra d2,loop2
  *lea 2(a1),a1
  *dbra d3,loop1
%end

%routine PLACE STRIP(%integer v,h,patt)
!Insert 16-bit value at reference point V,H
%integer fp,shift,x
  %return %if v >= frameheight %or h+16 >= framewidth
  fp = framebase+v*framemult+h>>3&(\1)
  shift = (\h)&15
  *move.l fp,a1
  *move.l shift,d1
  *move.l patt,d0
  *lsl.l d1,d0
  *or.l d0,(a1)
%end

%routine RULE(%integer v,h,length,depth)
%label last
%integer i,fp,shift
!printsymbol('R')
!write(v,1);write(h,1);write(length,1);write(depth,1);newline
  %return %if v < 0 %or h < 0
  length = framewidth-h %if framewidth-h < length
  %return %if length <= 0
  depth = frameheight-v %if frameheight-v < depth
  %return %if depth <= 0
  fp = framebase+v*framemult+h>>3&(\3)
  *move.l fp,a0;                        !framestore start ad
  *move depth,d1; *sub #1,d1
loop1:
  *move a0,a1
  *move #-1,d0;                         !32 1s
  *move #31,d3; *and h,d3; *lsr d3,d0;  !aligned for first word
  *add.l length,d3;                     !length + displacement
  *sub.w #1,d3;                         ! less one
  *move.w d3,d2; *lsr.w #5,d2;          !//32
  *sub.w #1,d2; *blt last;              !<= 32
  *or d0,(a1)+
  *move #-1,d0
  *sub.w #1,d2; *blt last;              !<= 32 left
loop2: 
  *or d0,(a1)+
  *dbra d2,loop2
last:
  *move #-1,d2
  *not.w d3; *and.w #31,d3; *lsl d3,d2
  *and d2,d0
  *or d0,(a1)
  *lea -frameinc(a0),a0
  *dbra d1,loop1
%end;  !RULE

%routine CIRCLE(%integer v,h,radius)
%integer x,y,rr,xx
!%integer fp
!!$IF CANON
!{  radius = framewidth-h %if framewidth-h < radius
!{  radius = frameheight-v %if frameheight-v < radius
!{  %return %if radius <= 0
!{  fp = framebase+v*framemult+h>>3&(\3)
!!$IF G1
!  radius = (radius+fac2)//factor;  radius = 1 %if radius = 0
!  h = (h+fac2)//factor
!  radius = framewidth-h %if framewidth-h < radius
!  v = (v+fac2)//factor
!  radius = frameheight-v %if frameheight-v < radius
!  %return %if radius <= 0
!  fp = framelim-v*framemult+h>>3&(\3);  !longword aligned
!!$FINISH
  y = 0;  x = radius;  xx = x*x;  rr = xx
  rule(v,h-x,x+x,1)
  %cycle
    y = y+1
    rr = rr-(y+y-1)
    %return %if rr <= 0
    %while xx > rr %cycle
      xx = xx-(x+x-1)
      x = x-1
      %return %if x <= 0
    %repeat
    rule(v+y,h-x,x+x,1)
    rule(v-y,h-x,x+x,1)
  %repeat
%end

%routine DRAWLINE(%integer X1,Y1,X2,Y2,W)
%constinteger STEP=1
%integer QSTEP=step, DX, DY
%integer E

%routine POINT(%integer X,Y)
%option "-nosass"
%integer i,j,k,ad
  %if rot = 0 %start
    y = y*framemult
    %for i = 1,1,w %cycle
      %return %if y >= framesize
      %for j = 1,1,w %cycle
        %return %if x >= framewidth
        ad = framebase+y + x>>3&(\1)
        shortinteger(ad) <- shortinteger(ad)!16_8000>>(x&15)
        x = x+1
      %repeat
      y = y+framemult;  x = x-w
    %repeat
  %else
    x = x*framemult
    %for i = 1,1,w %cycle
      %return %if x >= framesize
      %for j = 1,1,w %cycle
        %return %if y >= framewidth
        ad = framebase+x + y>>3&(\1)
        shortinteger(ad) <- shortinteger(ad)!16_8000>>(y&15)
        y = y+1
      %repeat
      x = x+framemult;  y = y-w
    %repeat
  %finish
%end
      
  dx = |x2-x1|;  dy = |y2-y1|
  %if dx >= dy %start
    %if dy = 0 %start
      %if x1 > x2 %start
        rule(y1-w,x2,dx,w)
      %else
        rule(y1,x1,dx,w)
      %finish
      %return
    %finish
    %if x1 > x2 %start
      x1 = x1-dx;  x2 = x2+dx;  !swop
      e = y1;  y1 = y2;  y2 = e
    %finish
    qstep = -qstep %if y1 > y2
    e = dx>>1
    %cycle
      point(x1,y1)
      e = e-dy
      %if e <= 0 %start;  ![was < 0]
        y1 = y1+qstep;  e = e+dx
      %finish
      x1 = x1+step
    %repeat %until x1 >= x2
  %else
    %if dx = 0 %start
      %if y1 > y2 %start
        rule(y2,x1,w,dy)
      %else
        rule(y1,x1-w,w,dy)
      %finish
      %return
    %finish
    %if y1 > y2 %start
      y1 = y1-dy;  y2 = y2+dy;  !swop
      e = x1;  x1 = x2;  x2 = e
    %finish
    qstep = -qstep %if x1 > x2
    e = dy>>1
    %cycle
      point(x1,y1)
      e = e-dx
      %if e <= 0 %start;  ![was < 0]
        x1 = x1+qstep;  e = e+dy
      %finish
      y1 = y1+step
    %repeat %until y1 >= y2
  %finish
  point(x2,y2)
%end
   
%routine PUT SYM DIRECT(%integer bfont,bchar,scale,rot,
                        %integername x0,y0)
%integer X,Y,LASTX,LASTY,XX,YY,YBIAS,XBIAS,EXTRA
%integer I,J
%record(bfontinfo)%name B
%record(vchari)%name VC
%record(xyinfo)%name VCC

%integerfn SCALED(%integer v)
  %result = -(((-v)*scale+half)>>8) %if v < 0
  %result = (v*scale+half)>>8
%end

  b == bindex(bfont)
  %return %if b == nil %or b_type = 1  {raster}
  vc == vcharvec(b,bchar)
  %return %if vc == nil
  extra = scale>>8
  scale = (b_scale*scale+half)>>8
  xbias = vc_xbias
  ybias  = vc_ybias
!Insert bits:      
  vcc == vc_xy(1)
  lastx = scaled(xbias);  lasty = scaled(ybias)
  %cycle
    x = vcc_x;  y = vcc_y
    xx = scaled(x&127-xbias);  yy = scaled(y&127-ybias)
    vcc == vcc[1]
    %if x&128 = 0 %start
      %if rot = 180 %then drawline(x0+lastx,y0+lasty,x0+xx,y0+yy,1) -
      %else %if rot = 90 %then drawline(x0-lasty,y0+lastx,x0-yy,y0+xx,1) -
      %else %if rot = 0 %then drawline(x0+lastx,y0-lasty,x0+xx,y0-yy,1) -
      %else %if rot = 270 %then drawline(x0+lasty,y0-lastx,x0+yy,y0-xx,1)
!      %if extra > 0 %start
!        i = extra
!        %if |lastx-xx| < |lasty-yy| %start
!          %cycle
!            drawline(lastx+x0+i,lasty+y0,xx+x0+i,yy+y0,1)
!            i = i-1
!          %repeat %until i = 0
!        %else
!          %cycle
!            drawline(lastx+x0,lasty+y0+i,xx+x0,yy+y0+i,1)
!            i = i-1
!          %repeat %until i = 0
!        %finish
!      %finish
    %finish
    lastx = xx;  lasty = yy
  %repeat %until y&128 # 0
  x0 = x0+scaled(vc_xmax+1)
%end; !PUT CHAR DIRECT

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Intermediate representation (current line):
%recordformat CHARINFO(%record(chari)%name CHAR {character info},
                       %byte STYLE {bold / slant},
                       %byte UNDER {underline displacement},
                       (%short VINC {vertical adjustment} %or %c
                        %short LINK {link to previous gap}),
                       %short INC {horizontal increment to next char})
%constinteger BOLDSHIFT=5
%integer ATOMS, CHARMAX, CHARS, UNDERSTATE
%integer ATOMSIZE, MAXATOMSIZE
%constinteger CHARBOUND=400
%record(charinfo)%array CHAR(0:charbound)
%record(charinfo)%name ATOMBASE;  !==char(charmax)
%record(charinfo)%name LASTCHAR;  !==char(charmax+chars)

%routine PUT SYM(%integer k,vdisp,style,under)
%integer i,j
%record(chari)%name c
  %return %if charmax+chars >= charbound
  chars = chars+1;  lastchar == char(charmax+chars)
  c == fbase_char(k&127)
  lastchar_char == c
  %if c_bfont&16_C0 # rot %and c_raster ## nil %start
    hmd release(c_raster);  c_raster == nil
  %finish
  charsize = fontwidth
  %if c_raster == nil %start
    c_bfont = c_bfont&63+rot
    c_raster == toraster(c_bfont&63,c_bchar,c_scale,rot>>6)
    charsize = spacewidth %if c_raster == nil
  %finish
  %if charsize <= 0 %start;  !not fixed pitch
    %if rot # 0 %then charsize = c_raster_ymax+1 %c
    %else charsize = c_raster_width
  %finish
  i = charsize+style>>boldshift
  lastchar_inc = i;  atomsize = atomsize+i
  maxatomsize = atomsize %if atomsize > maxatomsize
  lastchar_vinc = vdisp;  lastchar_style = style
  lastchar_under = under
%end

%routine PUT NULL(%integer vdisp,style,under)
  %return %if charmax+chars >= charbound
  chars = chars+1;  lastchar == char(charmax+chars)
  lastchar_char == nil
  charsize = 0
  lastchar_inc = 0
  lastchar_vinc = vdisp;  lastchar_style = style
  lastchar_under = under
%end

%routine PRINT LINE(%integer vbase,max)
%integer i,j,ustate,uhpos,b
%record(charinfo)%name p
%record(chari)%name c
%record(rasti)%name raster
  reset frame %if framestate # filling
  vbase = printwidth-vbase %if rot # 0
  horpos = char(0)_inc;  ustate = 0
  %for i = 1,1,max %cycle
    p == char(i)
    %if p_under # ustate %start
      %if ustate = 0 %start
        uhpos = horpos
      %else
        rule(vbase+ustate,uhpos,horpos-uhpos,1)
      %finish
      ustate = p_under
    %finish
    c == p_char
    %if c ## nil %start
      raster == c_raster
      %if rot # 0 %then place(horpos,vbase+p_vinc,raster) %c
      %else place(vbase+p_vinc,horpos,raster)
      %if p_style # 0 %start
        b = p_style>>boldshift
        %if b # 0 %start
          %for j = 1,1,b %cycle
            %if rot # 0 %then place(horpos+j,vbase+p_vinc,raster) %c
            %else place(vbase+p_vinc,horpos+j,raster)
          %repeat
        %finish
      %finish
    %finish
    horpos = horpos+p_inc
  %repeat
  rule(vbase+ustate,uhpos,horpos-uhpos,1) %if ustate # 0
%end

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

%recordformat pageinfo(%integer top,left,width,height,verpos,horpos,
                                rot)
%integer PSP, VERSET, HORSET
%record(pageinfo)%array PSTACK(1:8)

%routine RESET MACROS
%integer i
  def(i) = -1 %for i = 0,1,127
  def(i) = letsym %for i = 'A',1,'Z'
  def(i) = letsym %for i = 'a',1,'z'
  def(i) = 0 %for i = 128,1,255
  macfree = 1
  %for i = 0,1,bfbound %cycle
    bindex(i) == nil %if reslim <= addr(bindex(i)) <= storelim
  %repeat
  %for i = 0,1,dfbound %cycle
    dindex(i) == nil %if reslim <= addr(dindex(i)) <= storelim
  %repeat
  storefree = reslim
%end

%routine RESET GLOBALS
! not FONT, FONTYBIAS, FONTYMAX, FONTYDISP, FONTWIDTH
  spos = 0;  slim = 0
  macpos = 0;  msp = 0;  altmsp = 16
  macstack(0) = 0
  top = 0;  left = 0;  rot = 0;  penwidth = 0
  verpos = 0;  horpos = 0;  horset = 0;  verset = 0
  lineybias = 0;  lineydisp = 0;  lineheight = 0
  spacewidth = 30;  !nominal
  sym = nl;  insym = nl
%end

%integermap MAP(%integer i)
  %result == tab(i-tab0) %if i >= tab0
  %result == integer(addr(num)+i<<2)
%end

%constinteger BUILTINMAX=tab0+1;  !ASSIGN
%conststring(7)%array NAMES(1:builtinmax) =
  "ESCAPE",  "CAP",    "CAPSH",  "INVERT", "ASCII",
  "JUST",    "MARK",   "IGNORE", "START",
  "FINISH",  "PAGENO", "SECTNO", "MODE",
  "INDENT",
  "",
  "",   "",   "",  "",
  "TOP",     "BOTTOM", "PAGE",   "NLS",
  "LEFT",    "LINE",   "SGAP",   "PGAP",
  "TAB", "ASSIGN"

%routine RESET PARAMETERS
%integer i
%constintegerarray DEFAULT(1:tab0) =
 {ESCAPE} '$',
 {CAP} 0, {CAPSH} 0,
 {INVERT} 0,
 {ASCII} 1, {JUST} 0, {MARK} 0, {IGNORE} 0,
 {START} 1, {FINISH} 9999,
 {PAGENO} 0, {SECTNO} 0,
 {MODE} 0,
 {INDENT} 0,
 {} 0,
 {} 0, {} 0, {} 0, {} 0,
 {TOP} 2*vupi//3, {BOTTOM} 4*vupi//3,
 {PAGE} printheight-2*vupi, {NLS} vupi//8,
 {LEFT} 0, {LINE} printwidth,
 {SGAP} 2*hupi//12, {PGAP} 3*hupi//12, 0

  map(i) = default(i) %for i = 1,1,tab0;  !set default value
!  sgap = 2*spacewidth;  pgap = sgap+spacewidth
!  nls = fontymax+1
!  tab(i) = i*spacewidth*8 %for i = 0,1,tabbound
  tab(i) = i*(2*hupi//3) %for i = 0,1,tabbound
%end

%routine RESET LINE
  charmax = 0
  atombase == char(0);  lastchar == atombase;  lastchar = 0
  atoms = 0;  horpos = left
  chars = 0;  atomsize = 0;  maxatomsize = 0
%end

%routine PLACE STRIPS(%integer v,h,w)
%integer i,j,k
  get sym %until sym > ' '
  %while w > 0 %and sym > ' ' %cycle
    i = w;  i = 16 %if i > 16;  w = w-i
    j = 0
    %cycle
      k = sym-'0'
      %if k >= 0 %start
        k = k-7 %if k > 15;  get sym
      %finish %else k = 0
!      j = j<<4+k
      %if i = 16 %then j = j+k<<8 %c
      %else %if i = 12 %then j = j+k<<12 %c
      %else %if i = 8 %then j = j+k %c
      %else j = j+k<<4
      i = i-4
    %repeat %until i = 0
    place strip(v,h,j)
    h = h+16
  %repeat
%end

%routine DEFINE RASTER CHAR(%integer f,ch,ymax,ybias,xmax,xbias,width)
%integer ybytes,units,rbase,rsize,i,val,k,w,rb
%record(bfontinfo)%name b
%record(rasti)%name r
  %return %unless 33 <= ch <= 127
  b == bindex(f)
  ybytes = (ymax+1)<<1
  units = xmax>>4+1
  rsize = units*ybytes+rastheadlen
  r == newcell(rsize)
  b_absbase(ch) == r
  r_width = width
  r_xbias = xbias;  r_xmax = xmax
  r_ybias = ybias;  r_ymax = ymax
  rbase = addr(r_pattern(1))+ybytes
  get sym
  %while ymax >= 0 %cycle;  !for each strip
    get sym %while sym <= ' '
    rbase = rbase-2
    w = xmax+1;  rb = rbase
    i = 12;  val = 0
    %while w > 0 %cycle
      k = sym-'0'
      %if k >= 0 %start
        k = k-7 %if k > 15;  get sym
        val = val+k<<i
      %finish
      i = i-4
      %if i < 0 %start
        shortinteger(rb) <- val
        rb = rb+ybytes
        i = 12;  val = 0
      %finish
      w = w-4
    %repeat
    shortinteger(rb) <- val %if i # 12
    ymax = ymax-1
  %repeat
%end

%routine GET FONT NAME(%integer%name n1,n2)
  n1 = 0;  n2 = 0
  get sym %until sym # ' '
  %while sym >= ' ' %cycle
    sym = sym-('a'-'A') %if 'a' <= sym <= 'z'
    n1 = n2 %and n2 = 0 %if n2>>24 # 0
    n2 = n2<<8+sym
    get sym
  %repeat
  %while n1 = 0 %or n2>>24 = 0 %cycle
    n1 = n2 %and n2 = 0 %if n2>>24 # 0
    n2 = n2<<8+' '
  %repeat
%end

%integer%fn%spec BASIC FONT(%integer n1,n2,autofetch)

%routine PROCESS ESCAPE SEQUENCE
%integerarray arg(1:20)
%own%integer bfont=-1,dfont=-1
%integer args=0,n,code,sign,n1,n2
%switch e('A':'Z')

%routine FAULTY
  printstring("*Faulty escape sequence")
  newline
%end
  get sym
  get sym %if sym = '['
  %cycle
    n = 0;  sign = 0
    %cycle
      faulty %and %return %if sym < ' '
      %exit %if sym >= '0'
      sign = 1 %if sym = '-'
      get sym
    %repeat
    %exit %if sym > ';'
    args = args+1
    %while '0' <= sym <= '9' %cycle
     n = n*10+sym-'0'
     get sym
    %repeat
    n = -n %if sign # 0
    arg(args) = n
    get sym %if sym = ';'
  %repeat
  faulty %and %return %unless '@' <= sym <= 'Z'
  -> e(sym)
e('A'):  !Move up
  verpos = verpos-arg(1)
  verpos = top %if verpos < top
  %return
e('B'):  !Move down
  verpos = verpos+arg(1)
  %return
e('C'):  !Move right
  horpos = horpos+arg(1)
  %return
e('D'):  !Move left
  horpos = horpos-arg(1)
  horpos = left %if horpos < left
  %return
e('R'):  !Rotate
  rot = rem(rot+arg(1),360)//90*90
  %return
e('F'):  !Select font
  n = spacewidth
  select font(arg(1))
  spacewidth = n %if horset # 0
  %if verset = 0 %start
    lineydisp = fontydisp;  lineybias = fontybias
    lineheight = fontymax+1
  %finish
  %return
e('H'):  !Set horizontal inc
  spacewidth = arg(1)
  horset = 1
  %return
e('V'):  !Set vertical incs (ascender,descender)
  lineydisp = arg(1);  lineybias = arg(2)
  verset = 1
  %return
!Define basic font (type,ascender-height,descender-height,space-width)
e('S'):
  tfonts = tfonts+1
  get font name(n1,n2)
  %if arg(1) # 0 %start
nolv:
    printstring("Vector definition not yet supported")
    newline
    %return
  %finish
  bfont = new basic font(arg(1)!!1,arg(2),arg(3),arg(4),n1,n2)
  %return
!Define basic character (char,height,descender-height,
!                              xsize,xoffset,width)
e('K'):
  %return %if bfont <= 0
  arg(6) = arg(4) %if args < 6
  define raster char(bfont,arg(1),arg(2)-1,arg(3),arg(4)-1,arg(5),arg(6))
  %return
!Define derived font
!  (font-number; ascender-height; descender-height; space-width T
e('T'):
  dfont = arg(1)
  initialise derived font(dfont,arg(2)-1,arg(3)-1,arg(4))
  %return
!Define derived char
!  (char; number; base-char; scale; op; amount I font-name)
e('I'):
  get font name(n1,n2)
  %return %if dfont <= 0
  bfont = basic font(n1,n2,0)
  define derived chars(dfont,bfont,arg(1),arg(3),arg(2),arg(4))
  %return

!Graphics (mode,height,down-offset,width,left-offset,scale)
e('G'):
  -> nolv %if arg(1) # 0
  %while arg(2) > 0 %cycle
    place strips(verpos,horpos,arg(4))
    verpos = verpos+1
    arg(2) = arg(2)-1
  %repeat
  %return
e(*):
  report("Unimplemented code:",sym);  newline
%end

%routine PRINT GP
%switch S(0:31)
%record(chari)%name C
%on %event 9 %start
  close input
  %return
%finish
  lineheight = fontymax+1
nextsym:
  %cycle
    get sym
    reset frame %if framestate # filling
    -> s(sym) %if sym < ' '
    %if sym = ' ' %start
      horpos = horpos+spacewidth
    %else
      c == fbase_char(sym&127)
      %if c_bfont&16_C0 # rot %and c_raster ## nil %start
        hmd release(c_raster);  c_raster == nil
      %finish
      %if c_raster == nil %start
        c_bfont = c_bfont&63+rot
        c_raster == toraster(c_bfont&63,c_bchar,c_scale,rot>>6)
      %finish
      %if c_raster ## nil %start
        place(verpos+lineydisp,horpos,c_raster)
        %if fontwidth > 0 %then horpos = horpos+fontwidth %c
        %else horpos = horpos+c_raster_width
      %finish
    %finish
  %repeat

s(*):
  -> nextsym
s(esc):
  process escape sequence
  -> nextsym
s(rt):
  horpos = left
  -> nextsym
s(bs):
  horpos = horpos-spacewidth
  horpos = left %if horpos < left
  -> nextsym
s(lf):
  horpos = left
  verpos = verpos+lineheight
  -> nextsym %if verpos < printheight-lineydisp
s(ff):
  print page
  verpos = top;  horpos = left
  -> nextsym
%end

%routine PRINT PLAIN FILE(%integer f,t,l,a5)
%integer PAGE,HALFPAGE
%record(chari)%name C
%on %event 9 %start
  print page
  %return
%finish

  select font(f)
  lineydisp = fontydisp;  lineheight = fontymax+1
  horset = 0;  verset = 0
  psp = 0
  top = t*lineheight+lineydisp;  left = l*spacewidth
  %if a5=0 %start
    rot = 0
  !Note that VERPOS,HORPOS include TOP,LEFT
  ! (subtract off and add back on when changing TOP,LEFT)
    verpos = top;  horpos = left
    print gp
    print page
  %else
    halfpage = printheight>>1
    rot = 1<<6;  page = 0
    %cycle
      horpos = top
      %cycle
        verpos = printheight-left-page
        %cycle
          get sym
          reset frame %if framestate # filling
          %exit %if sym < ' '
          %if sym = ' ' %start
            verpos = verpos-lineheight
          %else
            %if verpos+page >= halfpage %start
              c == fbase_char(sym&127)
              %if c_bfont&16_C0 # rot %start
                hmd release(c_raster);  c_raster == nil
              %finish
              %if c_raster == nil %start
                c_bfont = c_bfont&63+rot
                c_raster == toraster(c_bfont&63,c_bchar,c_scale,rot>>6)
              %finish
              place(verpos,horpos,c_raster) %if c_raster ## nil
            %finish
            %if lineheight # 0 %then verpos = verpos-lineheight %c
            %else verpos = verpos-(c_raster_ymax+1)
          %finish
        %repeat
        horpos = horpos+fontwidth %if sym # rt
      %repeat %until horpos >= printwidth-fontwidth
      page = halfpage-page
      print page %if page = 0
    %repeat
  %finish
%end;  !PRINT PLAIN FILE

%integerfn BASIC FONT(%integer n1,n2,autofetch)
%integer i
%routine PRINT(%integer n)
%integer i
  printsymbol(n>>i&255) %for i = 24,-8,0
%end
%cycle
  %for i = 1,1,bfbound %cycle
    %result = i %if bindex(i) ## nil %and bindex(i)_name1 = n1 %c
                                     %and bindex(i)_name2 = n2
  %repeat
  %exit %if autofetch = 0
  autofetch = 0
  %if n1 = 'TIME' %start
    gname = "TIMES:"
    i = n2               {TIME SRxx}
    %cycle
      i = i<<8
      %exit %if i = 0 %or i>>24 = ' '
      gname = gname.tostring(i>>24)
    %repeat
    %if opened(gname) %start
      print gp
      curin = curin-1;  select input(curin)
    %finish
  %finish
%repeat
  printstring("**Unknown font name: ")
  print(n1);  print(n2);  newline
  %result = 0
%end

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

%routine PRINT VECTOR FILE(%integer scale,xzero,yzero,width)
%constinteger lineabs=0, moveabs=1, markerabs=2,
              linerel=3, moverel=4, markerrel=5,
              setdim=8, drawchar=9, setatt=10,
              newf=11
%switch s(0:15)
%integer charscale=scale>>1,bfont=16,charrot=0
%integer xbase,ybase,x,y,lastx,lasty,sx,sy,slastx,slasty,code,flip
%integer k

%routine GET NUM(%integername val)
  get sym %while sym <= ' '
  %if sym = '-' %start
    get sym
    get num(val);  val = -val
  %else
    val = 0
    %cycle
      val = val<<3+val+val+sym-'0'
      get sym
    %repeat %until %not '0' <= sym <= '9'
  %finish
%end

%integerfn HSCALED(%integer n)
  %if n >= 0 %start
    n = (n*scale)>>8
    %result = n %if n < cframewidth
  %finish
  printstring("X out of range for code");  write(code,1)
  printsymbol(':');  write(n,1)
  newline
  %result = 0 %if n < 0
  %result = cframewidth-1
%end
%integerfn VSCALED(%integer n)
  %if n >= 0 %start
    n = cframeheight-(n*scale)>>8
    %result = n %if n >= 0
    n = 0
  %finish
  printstring("Y out of range for code");  write(code,1)
  printsymbol(':');  write(n,1)
  newline
  %result = 0 %if n = 0
  %result = cframeheight-1
%end

%on %event 9 %start
  %return
%finish

!report("S ",scale);report("  XZ ",xzero);report("  YZ ",yzero);newline
  width = 1 %if width = 0
  xzero = xzero*unity//scale;  yzero = yzero*unity//scale
  xbase = -xzero;  ybase = -yzero
s(newf):
  lastx = xzero;  lasty = yzero
  slastx = hscaled(lastx);  slasty = vscaled(lasty)
  flip = 0
  get sym;  !prime SYM
  reset frame %if framestate # filling
next:
  get num(code)
  -> s(code&15) %if code&15 >= 8
  %if code&24 # 16 %start
    get num(x);  get num(y)
  %else
    get num(y);  x = y>>8&255;  x = x-256 %if x&128 # 0
    y = y&255;  y = y-256 %if y&128 # 0
  %finish
  -> s(code&15)
s(lineabs):
  x = x-xbase;  y = y-ybase
  sx = hscaled(x);  sy = vscaled(y)
  drawline(slastx,slasty,sx,sy,width)
  lastx = x;  lasty = y
  slastx = sx;  slasty = sy
  -> next
s(moveabs):
s(markerabs):
  x = x-xbase;  y = y-ybase
  sx = hscaled(x);  sy = vscaled(y)
  lastx = x;  lasty = y
  slastx = sx;  slasty = sy
  -> next
s(linerel):
  x = lastx+x;  y = lasty+y
  sx = hscaled(x);  sy = vscaled(y)
  drawline(slastx,slasty,sx,sy,width)
  lastx = x;  lasty = y
  slastx = sx;  slasty = sy
  -> next
s(moverel):
s(markerrel):
  x = lastx+x;  y = lasty+y
  sx = hscaled(x);  sy = vscaled(y)
  lastx = x;  lasty = y
  slastx = sx;  slasty = sy
  -> next
s(setdim):
  %if flip = 0 %start;  !specifying X DIM
    get num(xbase);  xbase = xbase-xzero
    get num(x);  x = x-xbase
    %if x*scale > cframewidth*unity %start
      printstring("X dimension too big.  Changing scale from")
      print(scale/unity,1,3)
      scale = scale-1 %until x*scale <= cframewidth*unity
!      scale = scale*cframewidth//x
      printstring(" to")
      print(scale/unity,1,3);  newline
      charscale = scale>>1
    %finish
  %else
    get num(ybase);  ybase = ybase-yzero
    get num(y);  y = y-ybase
    %if y*scale > cframeheight*unity %start
      printstring("Y dimension too big.  Changing scale from")
      print(scale/unity,1,3)
      scale = scale-1 %until y*scale <= cframeheight*unity
!      scale = scale*cframeheight//y
      printstring(" to")
      print(scale/unity,1,3);  newline
      charscale = scale>>1
    %finish
  %finish
  flip = 1-flip
  -> next
s(drawchar):
  put sym direct(bfont,code>>4&255,charscale,rot,slastx,slasty)
  -> next
s(setatt):
  bfont = code>>4&255 %if code>>12 = 5;    !set font
  charrot = code>>4&255 %if code>>12 = 3;  !set orientation
  -> next
s(15):
  get num(x)
  %if code>>12 = 2 %start; !set char size
    charscale = (scale*x)//24
  %finish
  -> next
s(*):
  %signal 9
%end

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

%routine PRINT SANDERS FILE(%integer x)
!Process Sanders Variflex 700 format file (ESL format only)

%constinteger DEFAULT TOP=0, DEFAULT BOTTOM=0,
              DEFAULT LEFT=0, DEFAULT RIGHT=0,
              DEFAULT FORM WIDTH=7000, DEFAULT FORM LENGTH=10000,
              DEFAULT COL=96, DEFAULT ROW=120

%integer SANTOP, SANBOTTOM, SANLEFT, SANRIGHT,
         SANFORMLENGTH, SANFORMWIDTH,
         SANCOL, SANROW
%integer SANHPOS, LASTHPOS, SANVPOS, LASTVPOS, LASTWIDTH, LASTHEIGHT,
         BREAK, MARGIN, PEND, INDENT, INDENT1,
         FILLING, PROCESSING, DRAFTING,
         TOPPING, JUST, INC, DEC, JGAP, NGAP,
         UNDERLINE, BOLDING

%constinteger LEADIN=esc

%ownbytearray FONTMAP(0:31) =
  0,0,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
  2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2

%ownbytearray FONTHEIGHT(0:31) =
  0 (*)

%integerfn HSCALED(%integer n)
  %result = n*hupi//960
%end
%integerfn VSCALED(%integer n)
  %result = n*vupi//288
%end

%routine RESET
!Restore all print parameters to default values
  santop = defaulttop;  sanbottom = defaultbottom
  sanleft = defaultleft;  sanright = defaultright
  sanformlength = defaultformlength;  sanformwidth = defaultformwidth
  filling = 0;  processing = 0;  drafting = 0
  topping = 1;  just = 0;  inc = 0;  dec = 0;  jgap = 0;  ngap = 0
  underline = 0;  bolding = 0;  indent = 0;  indent1 = 0
%end

%routine PROCESS SANDERS COMMAND
%integer c,n,m,f1,f2,i,j,f23
%record(bfontinfo)%name b
%switch s(0:127)

%routine ERROR(%string(31) message)
  printsymbol('*');  printstring(message)
  printstring(": ")
  %unless ' ' < c < 127 %then write(c,0) %c
  %else printsymbol('''') %and printsymbol(c) %and printsymbol('''')
  %if n # -999999 %start
    print string(" (Parm:");  write(n,1);  printsymbol(')')
  %finish
  newline
%end

%integerfn CHAR
%integer k
  k = sym
  get sym
  get sym %if sym = ','
  %result = k
%end
%integerfn NUM(%integer size)
%integer k
  k = sym-'@'
  %if k >= 0 %start
    %cycle
      get sym %until sym # lf
      size = size-1
      %exit %if size <= 0
      error("Faulty number") %and %exit %if sym < '@'
      k = k<<6+(sym-'@')
    %repeat
  %finish
  %result = k
%end
%integerfn ONOFF
  %result = num(1)>>5
%end
%integerfn QUAD
%integer i,j,k
  j = 0
  %for i = 1,1,4 %cycle
    k = 0
    %if sym > ' ' %start
      k = char;  k = k&letmask %if 'a' <= k <= 'z'
    %finish
    j = j<<8+k
  %repeat
  %result = j
%end

  n = -999999
  get sym %until sym # lf;  c = sym
  %if c < '0' %start
    %if c = sub %start
      get sym %until sym # lf
    %finish
  %finish
  get sym %until sym # lf
  -> s(c)
s(26):  !Reset (ESC SUB I)
  reset
  %return
s('S'):  !Pause
  select input(0)
  skip symbol
  select input(1)
  %return
s(bel):  !Bell
  printsymbol(bel)
  %return
s(lf):   !Reverse LF
  sanvpos = sanvpos-lastheight
  %return
s('V'):  !Disable/enable top/bottom
  topping = onoff
  %return
s('d'):  !Assign logical font
!**temp: doesn't allow for variable/multiple scaling
  n = num(1)
  f1 = quad;  f2 = quad
  %if n&(\31) = 0 %start
    { Fix for small fonts (less than 10 points) where the last two bytes }
    { of f2 have to be swapped (and the third made '0') to give the }
    { correct point size.}
    %if f2&16_FF=0 %start                   { 4th byte 0 }
      f23 = (f2&16_0000FF00)>>8             { 3rd byte of f2 }
      f2 = f2&16_FFFF0000
      f2 = f2!16_00003000!f23               { Swap bytes insterting '0' }
    %finish
    i = (f2>>8&15)*10 + f2&15
    %if f1 = 'FONT' %start
      fontmap(n) = i
    %else %if f1 = 'TIME'
      j = sym
      i = basic font(f1,f2,1)
      sym = j
      %return %if i = 0
      b == bindex(i)
      %return %if b_type # 1;       !must be raster
      initialise derived font(n+5,b_ymax,b_ybias,b_width)
      define derived chars(n+5,i,33,33,95,unity)
      fontmap(n) = n+5
    %else
      j = (((f1&15)*10+(f2>>24&15))*10 + f2>>16&15 )<<8//100
      define scaled font(n+5,i,j,0,0,0)
      fontmap(n) = n+5
    %finish
  %finish %else error("Font no out-of-range")
  %return
s('a'):  !Select font
  n = num(1)
  %if n&(\31) # 0 %then error("Font no out-of-range") %else %start
    select font(fontmap(n))
  %finish
  %return
s('t'):  !Draft on/off
  drafting = onoff
  %return
s('l'):  !Move horizontally
  n = num(2);  n = n-4096 %if n&2048 # 0
  sanhpos = sanhpos+n
  %return
s('o'):  !Move vertically
  n = num(2);  n = n-4096 %if n&2048 # 0
  sanvpos = sanvpos+n
  break = 1
  %return
s(bs):  !Backspace
  sanhpos = sanhpos-spacewidth
  %return
s('N'):  !Non-escape
  sanhpos = sanhpos-lastwidth
  %return
s('i'):  !Set Form Length
  n = num(3)
  n = default form length %if n <= 0
  m = 0;  m = santop+sanbottom %if topping # 0
  %if n <= m %or n > 32768 %start
    error("Value out-of-range");  n = default form length
  %finish
  sanformlength = n
  %return
s('e'):  !Set Line length
  n = num(3)
  n = n+sanleft+sanright %if n > 0
  n = default form width %if n <= 0
  %if n <= sanleft+sanright %or n > 12288 %start
    error("Value out-of-range");  n = default form width
  %finish
  sanformwidth = n
  %return
s('f'):  !Set Left Margin
  sanleft = default left
  n = num(3)
  %if n > 0 %start
    %if n > 12096 %then error("Value out-of-range") %else sanleft = n
  %finish
  %return
s('T'):  !Set Top Margin
  santop = default top
  n = num(3)
  %if n > 0 %start
    santop = n
  %finish
  %return
s('B'):  !Set Bottom Margin
  sanbottom = default bottom
  n = num(3)
  %if n > 0 %start
    sanbottom = n
  %finish
  %return
s('u'): !Begin/End Underlining
  n = num(1)
  %if n >= 32 %start
    underline = n-32;  underline = 7 %if underline = 0
  %else
    underline = 0
  %finish
  n = hscaled(sanhpos)
  lastchar_inc = n-lasthpos
  lasthpos = n
  put null(0,0,underline)
  %return
s('b'): !Begin/End Bolding
  n = num(1)
  %if n < 32 %then bolding = 0 %else bolding = 2<<boldshift
  %return
s('n'):  !Set Justification Mode
  just = num(1)
  %return
s('w'):  !Set Word Spacing
  jgap = spacewidth;  ngap = spacewidth
  n = num(2)
  %if n > 0 %start
    jgap = n
  %finish
  n = num(2)
  %if n > 0 %start
    ngap = n
  %finish
  %return
s('j'):  !Set Letter Spacing
  dec = 0;  inc = 0
  n = num(2)
  dec = n %if n > 0
  n = num(2)
  inc = n %if n > 0
  %return
s('k'):  !set Line Height
  n = num(2)
  sanrow = n
  fontheight(font) = n
  %return
s('I'):  !Set single-line Indent
  n = num(3)
  indent1 = n
  %return
s('g'):  !set Hanging Indent
  n = num(3)
  indent = n
  %return
s('C'):  !set Column Width
  sancol = spacewidth
  n = num(3)
  sancol = n %if n > 0
  %return
s(*):
  error("Unknown command")
%end;  !PROCESS SANDERS COMMAND

%integer i,j
%record(charinfo)%name p
%on %event 9 %start
  %return
%finish

reset;  reset line
pend = 0;  lasthpos = 0;  sanhpos = 0
%cycle
  lastvpos = 0;  sanvpos = 0
  %cycle
    break = 0
    %cycle
      %if pend # 0 %then sym = pend %and pend = 0 %else get sym
%continue %if sym = lf;  !**for now : VAX**
      reset frame %if framestate # filling
      %if sym < ' ' %start
        %exit %if sym # leadin
        process sanders command
        pend = sym
        %exit %if break # 0
      %else
        i = hscaled(sanhpos)
        lastchar_inc = i-lasthpos
        lasthpos = i
        put sym(sym,0,bolding,underline);  !sets CHARSIZE
        sanhpos = sanhpos+charsize*960//hupi
      %finish
    %repeat
    %if chars # 0 %start
      i = 0;  i = santop %if topping # 0
      print line(vscaled(i+lastvpos){+fontydisp},chars)
      reset line
      lasthpos = 0
    %finish
    lasthpos = 0 %and sanhpos = sanleft+indent1 %and pend = 0 %if sym = rt
    sanvpos = sanvpos+sanrow %and pend = 0 %if sym = lf
    lastheight = sanvpos-lastvpos
    lastvpos = sanvpos
    i = sanformlength;  i = i-sanbottom %if topping # 0
  %repeat %until sym = ff %or lastvpos >= i
  print page
  lastvpos = 0 %and sanvpos = 0 %and pend = 0 %if sym = ff
%repeat
%end;  !SANDERS

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

%constinteger NESTBOUND=1000
%recordformat NESTINFO(%integer value, %short vintage,which)
%record(nestinfo)%array NEST(1:nestbound)
!
%routine PRINT LAYOUT FILE(%integer initfont)
!
%bytearray VINTAGE(0:parmbound)

%constinteger UNDDISP=5, SUPDISP=3

%integer LEVEL=1, INDENTUSED=0
%integer XLINES=0, XATOMS=0;  !explicit lines($L), atoms($A,$W)
%integer INDENTIND=\0;        !flag to enable indenting (normal)
%integer PAGES=0;             !total pages printed
%integer LINECAPIND=0,LINEMIDIND=0,CLOSEBRACKET=0
%integer LINEBREAKER=0
%integer XPAGE=1;             !flag for explicit new page

%integer NAME,RELIND,NONUM
%integer PAGELIM,LINELIM
%integer LASTSYM, ATOMLASTSYM
%integer SYMCODE
%integer GAPS, SGAPS, LASTGAP, SPACING
%integer ATOMYDISP, ATOMYBIAS
%integer HOLDFONT, HOLDUNDER, HOLDBOLD, HOLDSLANT
%integer FAULTPOS;          !(anticipated) error pos in SOURCE
%integer LINESTART, LINEMACPOS
%integer UPPER;             !flag for upper-case atom
%integer NP;               !nest pointer
%integer FLINK
%integer I,J
!
%routine PRINT SOURCE LINE
%integer i,k
  i = linemacpos
  %if i # 0 %start
    %while mac(i) > nl %cycle
      print symbol(mac(i));  i = i+1
    %repeat
    newline
  %else
    i = linestart
    %cycle
      printsymbol('^') %if i = faultpos
      k = source(i&smax);  printsymbol(k);  i = i+1
    %repeat %until k = nl
  %finish
  faultpos = -1
%end   { print source line }

%routine FAULT(%string(31) s)
  print source line
  printsymbol('*');  printstring(s)
  newline
%end

%routine RANGEFAULT
  fault("Out of bounds")
%end

%routine READ SOURCE LINE
%integer k
  %on %event 9 %start;  !input ended
    %if curin = 1 %start
      source(slim&smax) = escape;  slim = slim+1
      source(slim&smax) = 'E';  slim = slim+1
      source(slim&smax) = nl;  slim = slim+1
      %return
    %finish
    curin = curin-1;  select input(curin)
  %finish
  %if slim-spos > 0 %start;  !buffer not empty
    !fairly full or at least a complete line
    %return %if slim-spos >= smax-1000 %or source((slim-1)&smax) = nl
  %finish
  %cycle
    read symbol(k)
    k = nl %if k < ' ' %or k >= 127
    source(slim&smax) = k;  slim = slim+1
  %repeat %until k = nl
%end   { read source line }

%routine COMPLAIN(%string(31) k)
  printstring(k);  write(spos,1);  write(slim,1)
  %if sym >= ' ' %then printsymbol(sym) %else write(sym,0)
  %if insym >= ' ' %then printsymbol(insym) %else write(insym,0)
  newline
%end

%routine READ SYM
  linemacpos = macpos %if sym = nl
  %while macpos # 0 %cycle
    sym = mac(macpos);  macpos = macpos+1
    %return %if sym # 0
    macpos = macstack(msp);  msp = msp-1 %if msp # 0
  %repeat
  read source line %and linestart = spos %if insym = nl
complain("Reading ") %if spos >= slim
  insym = source(spos&smax);  spos = spos+1
  sym = insym
%end   { read sym }

%integerfn NEXT SYM
!Line known to be there
  %result = mac(macpos) %if macpos # 0;  !*0 if end of macro*
complain("Nexting ") %if spos >= slim
  %result = source(spos&smax)
%end   { next sym }

%predicate A LETTER
!Reads sym if letter
%integer k
  k = nextsym&letmask
  %false %unless 'A' <= k <= 'Z'
  sym = k
  %if macpos # 0 %then macpos = macpos+1 %else spos = spos+1
  %true
%end   { a letter }

%predicate A DIGIT
%integer k
  k = nextsym
  %false %unless '0' <= k <= '9'
  sym = k
  %if macpos # 0 %then macpos = macpos+1 %else spos = spos+1
  %true
%end   { a digit }

%predicate A(%integer k)
!K # NL
  %false %unless nextsym = k
  sym = k
  %if macpos # 0 %then macpos = macpos+1 %else spos = spos+1
  %true
%end   { a }

%routine SKIP ONE SPACE
  %if nextsym = ' ' %start
    sym = ' '
    %if macpos # 0 %then macpos = macpos+1 %else spos = spos+1
  %finish
%end   { skip one space }

%routine READ NAME
!First letter in SYM
!Names are ordered as follows:
!          1 : TAB0       -- layout parameters
!       TAB1 : TABBOUND   -- gap for tab values
!        'A' : 'Z'        -- single letter names
!     'Z'+1  : ...        -- other built-in cases
!        128 : 255        -- other names
%integer i,j
  name = sym&letmask;  !'A' to 'Z' (if single letter)
  %if a letter %start;  !more than one letter
    i = namefree+1;  nchar(i) = name
    %cycle
      i = i+1;  nchar(i) = sym
    %repeat %until %not a letter
    nchar(namefree) = i-namefree;  !length
    j = 1;  name = 1
    %while string(addr(nchar(j))) # string(addr(nchar(namefree))) %cycle
      j = j+nchar(j)+1;  name = name+1
    %repeat
    %if name > tab0 %start
      %if name > builtinmax %start
        name = name-builtinmax+128
        namefree = i+1 %if j = namefree
      %else
        name = 'A';  !ASSIGN
      %finish
    %finish
  %finish
%end   { read name }

%routine READ NUM(%integer unit)
%integer frac,fdiv,div
  relind = 0
  relind = sym %if a('+') %or a('-')
  %if a digit %start
    num = sym-'0';  nonum = 0
    num = num*10+sym-'0' %while a digit
    %if unit # 0 %start
      frac = 0
      %if a('.') %start
        fdiv = 1
        %while a digit %cycle
          frac = frac*10+sym-'0';  fdiv = fdiv*10
        %repeat
      %finish
      div = 1
      %if a('/') %start
        div = 0
        div = div*10+sym-'0' %while a digit
      %finish
      unit = hupi %if a('"');  !***assumes VUPI=HUPI***
      num = num*unit
      num = num+frac*unit//fdiv %if frac > 0
      num = num//div %if div > 1
    %finish
  %else
    num = unit;  num = 1 %if num = 0
    nonum = 1
  %finish
  num = -num %if relind = '-'
%end   { read num }

%routine PUSH(%integer which)
!write(which,1);write(map(which),1);newline
  croak("Nest overflow") %if np >= nestbound
  nest(np)_value = map(which);  nest(np)_vintage = vintage(which)
  nest(np)_which = which
  np = np+1
%end   { push }

%routine NEW VINTAGE(%integer close)
  nest(np)_vintage = 0;  nest(np)_which = closebracket
  np = np+1;  level = level+1
  closebracket = close
%end   { new vintage }

%routine PUSH VALUE(%integer for)
  %if vintage(for) # level %start
    push(for) %if vintage(for) < level
    vintage(for) = level
  %finish
%end   { push value }

%routine END VINTAGE
  verpos = verpos-top;  horpos = horpos-left;  !in case change of TOP,LEFT
  %cycle
    np = np-1
!    %if np <= atomnp %start;  !must be atom boundary
!      place atom %if chars # 0
!    %finish
    %exit %if nest(np)_vintage = 0;  !boundary mark
!write(nest(np)_which,1);write(nest(np)_value,1)
    vintage(nest(np)_which) = nest(np)_vintage
    map(nest(np)_which) = nest(np)_value;  !NUM if discharged
  %repeat
  verpos = verpos+top;  horpos = horpos+left
  {pagelim = page+top;  }linelim = line+left
  select font(font)
  level = level-1
  closebracket = 0
  closebracket = nest(np)_which %if np > 1
%end   { end vintage }

%routine REPORT MISSING
  %if closebracket = 0 %start
    printstring("**Internal error 1");  newline
    %signal 9
  %finish
  fault("Missing closing bracket: ".tostring(closebracket))
  end vintage
%end   { report missing }

%constbytearray BRACKET(0:127) =
  0 (32), { :}' ', 0 (7), {(:}')',
  0 (19), {<:}'>', 0 (30), {[:}']',
  0 (31), {{:}'}',  0(4)

%routine GET TERMINATOR(%integer for)
%integer j
  j = bracket(nextsym)
  %if j # 0 %start
    %if macpos # 0 %then macpos = macpos+1 %else spos = spos+1
    new vintage(j) %if j > ' '
  %finish
  push value(for) %if for # 0
%end   { get terminator }

%routine PUTNUM(%integer v)
  putnum(v//10) %and v = v-v//10*10 %while v >= 10
  put sym(v+'0',0,0,0)
%end   { putnum }

%routine RESET DOC LINE
  %if xlines # 0 %start
    xlines = xlines-1
    %if xlines = 0 %start
      report missing %while closebracket # -'L'
      end vintage
      linecapind = 0;  linemidind = 0
      indentind = \0
    %finish
  %finish
  reset line
  gaps = 0;  sgaps = 0;  lastgap = 0
  lastsym = 0
  disp = 0
  lineybias = 0;  lineydisp = 0
  spacing = tab(indent)&indentind
%end   { reset doc line }

%routine SWITCH CONTEXTS
%integer i
  %if msp >= 16 %start;  !processing text
    holdfont = font;  holdunder = under
    holdbold = bold;  holdslant = slant
  %else;                 !within 'format'
    %if holdfont # font %start
      font = holdfont;  select font(font)
    %finish
    under = holdunder;  bold = holdbold;  slant = holdslant
  %finish
  macstack(msp+1) = macpos;  !preserve
  i = altmsp;  altmsp = msp;  msp = i
  macpos = macstack(msp+1)
%end   { switch contents }

%routine CLOSE PAGE
!  %if macstack(0) # 0 %start;  !format active
!    switch contexts
!  %else
    %if pageno # 0 %start
      charmax = 0;  atombase == char(0)
      chars = 0;  atomsize = 0;  maxatomsize = 0
      %if sectno # 0 %start
        putnum(sectno);  put sym('-',0,0,0)
      %finish
      putnum(pageno)
      char(0)_inc = left+(line-maxatomsize)//2
      print line(pagelim+bottom//2,chars) %if pages+1 >= start
    %finish
    print page %if pages+1 >= start
    verpos = top;  pagelim = page+top
    pages = pages+1
    pageno = pageno+1 %if pageno # 0
!  %finish
%end   { close page }

%routine PRINT DOC LINE
%integer extra
  %if charmax > 0 %start;  !something on line
    extra = left
    extra = extra+(linelim-horpos)//2 %if linemidind # 0
    char(0)_inc = char(0)_inc+extra
    print line(verpos+lineydisp,charmax-1) %if pages+1 >= start
    horpos = left
  %finish
  lineheight = lineybias+lineydisp+1
  lineheight = nls %if nls > lineheight
  verpos = verpos+lineheight
  close page %if verpos+lineydisp >= pagelim
  reset doc line
  xpage = 0
%end   { print doc line }

%routine JUSTIFY
%owninteger flip=0
%integer i,j,k,min,count,scount,await,swait
%record(charinfo)%name p
  count = linelim-horpos;      !unfilled space
  %return %if count <= 0 %or gaps = 0
  min = count//gaps;             !extra spacing for each gap
  count = count-min*gaps;        !remainder
  scount = sgaps;                !prefer sentence gaps
  scount = count %if count < sgaps
  count = count-scount;          !remainder for atom gaps
  flip = 1-flip
  %if flip = 0 %start;           !extra spaces from rh end
    swait = 0;  await = 0;       !start at once
  %else
    swait = sgaps-scount;  await = gaps-sgaps-count
  %finish
  %while lastgap # 0 %cycle
    p == char(lastgap)
    %if p_style # 0 %start;  !sentence gap
      %if swait = 0 %start
        p_inc = p_inc+1 %and scount = scount-1 %if scount # 0
      %finish %else swait = swait-1
    %else;      !atom gap
      %if await = 0 %start
        p_inc = p_inc+1 %and count = count-1 %if count # 0
      %finish %else await = await-1
    %finish
    p_inc = p_inc+min
    lastgap = p_link
  %repeat
  horpos = linelim
%end   { justify }

%routine PLACE ATOM
%integer sent,i,j,max
%record(charinfo)%name p
  sent = 0
!! in case $c- used
  lastchar_inc = lastchar_inc+(maxatomsize-atomsize) %if maxatomsize-atomsize>0
  %if lastsym # 0 %and xlines = 0 %start
    %if upper > 0 %c
    %and (lastsym = '.' %or lastsym = '?' %or lastsym = '!') %start
      spacing = sgap %if spacing < sgap
      sent = 1
    %finish
    %if horpos+spacing+maxatomsize > linelim %start;  !no room for new atom
      max = charmax;  j = chars
      justify %if just # 0
      print doc line;            !(resets SPACING,GAPS,etc)
      atoms = 0;  sent = 0
      chars = 0;  atomsize = 0;  maxatomsize = 0
      %for i = 1,1,j %cycle
        p == char(max+i)
        chars = chars+1;  lastchar == char(charmax+chars)
        lastchar = p
        atomsize = atomsize+lastchar_inc
        maxatomsize = atomsize %if atomsize > maxatomsize
!        put sym(p_char_bchar,p_vinc,p_style,p_under)
      %repeat
    %else
      gaps = gaps+1;  sgaps = sgaps+1 %if sent # 0
    %finish
  %finish
  %if xatoms # 0 %start
    xatoms = xatoms-1
    %if xatoms = 0 %start
      report missing %while closebracket > 0
      end vintage
    %finish
  %finish
  atombase_inc = atombase_inc+spacing
  atombase_style = sent
  atombase_link = lastgap;  lastgap = charmax %if lastsym # 0
  horpos = horpos+spacing+maxatomsize
  charmax = charmax+chars+1;  atombase == char(charmax)
  spacing = 0;  chars = 0;  atomsize = 0;  maxatomsize = 0
  atombase_char == nil;  atombase_under = 0
  atombase_inc = 0
  lastsym = atomlastsym
  atomydisp = fontydisp %if atomydisp = 0
  lineydisp = atomydisp %if atomydisp > lineydisp
  atomybias = fontybias %if atomybias = 0
  lineybias = atomybias %if atomybias > lineybias
  linebreaker = 0
%end   { place atom }

%routine CHECK TAB NAME
  read num(1);  num = 1 %if num <= 0
  name = name+num
  %return %if name <= parmbound
  rangefault
%end   { check tab name }

%routine READ LAYOUT NAME
%integer i
  faultpos = spos %and read sym %until sym # ' '
  %if 'A' <= sym&letmask <= 'Z' %start
    read name
    %if name <= tab0 %start
      check tab name %if name = tab0;  !TAB
      %return
    %finish
    fault("Unknown name")
  %finish %else fault("Faulty format")
  name = 0
%end   { read layout name }

%routine ASSIGN(%integer skipspace)
%integer i,j,k,oldtop
  i = name;  %return %if i = 0
  oldtop = top;  horpos = horpos-left
  indentused = 1 %if i = iname
  read sym %until sym # ' '
  %if sym = '<' %or sym = '>' %start;  !push, pop
    j = i
    %cycle
      %if sym = '<' %start;  !save current value
{printstring("Pushing ".names(j));  write(np,1);  newline
        push(j)
      %else;  !restore old value
{printstring("Popping ".names(j));  write(np,1);  newline
        k = np
        %cycle
          fault("Nest underflow") %and %return %if k = 1
          k = k-1
        %repeat %until nest(k)_which = j
        nest(k)_which = 0
        map(j) = nest(k)_value
        vintage(j) = nest(k)_vintage
        np = np-1 %while np > 1 %and nest(np-1)_which = 0
      %finish
      j = j+1
      %exit %if j <= tab0 %or j >= tab0+tabbound
    %repeat
    read sym %while nextsym = skipspace
    -> end %if nextsym = ';' %or nextsym <= ' '
  %else
    faultpos = spos-1
    fault("Faulty format") %and %return %if sym # '='
  %finish
  %cycle
    read sym %while nextsym = ' '
    %if a letter %start;  !rhs also parameter
      read layout name;  j = name;  %return %if j = 0
    %else
      %if a('''') %start
        read sym;  num = sym;           !quoted symbol
        read sym;                       !quotemark (presumably)
      %else
        %if i >= leftname %then read num(spacewidth) %c
        %else %if i >= topname %then read num(nls) %c
        %else read num(0)
        num = map(i)+num %if relind # 0
        num = 0 %if num < 0
      %finish
      j = 0
    %finish
    %cycle
      map(i) = map(j);                ! n.b. map(0) == num
      %if vintage(i) # level %start
        push(i) %if vintage(i) < level
        vintage(i) = level
      %finish
      i = i+1;  j = j+1
      %exit %if j <= tab0
      %exit %if i <= tab0 %or i >= tab0+tabbound
    %repeat
  %repeat %until i < tab0 %or %not a(',')
  read sym %while nextsym = skipspace
end:
  verpos = top %and pagelim = page+top %if verpos = oldtop
  horpos = horpos+left
  linelim = line+left
%end   { assign }

{ Start of print layout file }
%constinteger breakers=2_111010010011111011001100110
!                        ZYXWVUTSRQPONMLKJIHGFEDCBA@
%integer c,t,hold,cstate,atomcapind
%switch d('A':'Z')

  namefree = 1;  np = 1
  %for i = 1,1,builtinmax %cycle
    string(addr(nchar(namefree))) = names(i);  !set name in dict
    namefree = namefree+nchar(namefree)+1
  %repeat
  vintage(i) = 1 %for i = 0,1,parmbound
  reset parameters
  pagelim = page+top;  linelim = line+left
  reset doc line
  sym = nl;  insym = nl;  verpos = top
next:
  %while pages < finish %cycle
    !Read characters comprising next atom (possibly null) to CHAR
    chars = 0;  atomsize = 0;  maxatomsize = 0;  upper = 0
    atomydisp = 0;  atomybias = 0
    atomcapind = linecapind
    disp = 0
    spacing = spacewidth %if lastsym # 0;  !atom-separating space
    %cycle;  !skip spaces
      read sym
      %exit %if sym # ' '
      !significant space if (a) initial or (b) after explicit pos
      !  or (c) governed by $L
      spacing = spacing+spacewidth %if lastsym = 0 %or xlines # 0
    %repeat
    %if sym = capsh %start
      atomcapind = casebit;  read sym
    %finish
    %cycle
      cstate = atomcapind
      %if sym <= ' ' %start
        %if chars # 0 %start
          place atom
          atombase_under = under
        %finish
        %if sym = nl %start
          %if xlines # 0 %or (linebreaker=0 %and horpos = left) %start
            print doc line
          %else %if linebreaker = 0
            read source line %if spos = slim
            print doc line %if nextsym <= ' '
          %finish
          linebreaker = 0
        %finish
        %exit
      %finish
      %if sym = escape %start
        faultpos = spos
        %if a letter %start
          read name
          %if name <= tab0 %start;  !layout parameter
            check tabname %if name = tab0
            assign(0)
          %else %if name >= 128;  !non-basic directive
            get terminator(0)
            i = def(name)
            %if i > 0 %start
              msp = msp+1;  macstack(msp) = macpos
              macpos = i
            %finish %else fault("Unknown directive")
          %else;                           !basic
            %if name = 'H' %start;    !heavy (bold)
              read num(1)
              num = boldsteps %if nonum # 0
              get terminator(hname)
              %if bold = 0 %then bold = num %else bold = 0
            %else %if name = 'U';          !underline
              read num(1)
              num = unddisp %if nonum # 0
              get terminator(uname)
              %if under = 0 %then under = num %else under = 0
            %else %if name = 'A' %and (nextsym = '$' %or '0' <= nextsym <= '9')
              read num(1)
              skip one space
              %if num > 0 %start
                new vintage(-'A') %if xatoms = 0
                xatoms = num
              %finish
            %else %if name = 'W';           !explicit words
              read num(1)
              skip one space
              %if num > 0 %start
                new vintage(-'W') %if xatoms = 0
                xatoms = num
              %finish
            %else %if name = 'R';    !row
              read num(fontymax+1)
              ->d('R') %if relind = 0
              get terminator(dname)
              disp = disp+num
            %else %if sym = 'C'
              read num(spacewidth)
              skip one space
              num = num+(horpos-left+spacing+atomsize) %if relind # 0
              ->setpos %if chars = 0
              num = num-(horpos-left+spacing+atomsize)
              lastchar_inc = lastchar_inc+num;  atomsize = atomsize+num
            %else;  !atom-breaker
              place atom %if chars # 0
              linebreaker = breakers>>(name-'@')&1
              %if linebreaker # 0 %start
                %if xatoms # 0 %start
                  fault("Spurious directive") %if xatoms > 0
                  report missing %while closebracket > 0
                  end vintage
                  xatoms = 0
                %finish
                %if xlines # 0 %start
                  fault("Spurious directive") %if xlines > 0 %or charmax+chars # 0
                  xlines = 1;  reset doc line
                %finish
                %if charmax+chars # 0 %start
                  justify %if name = 'J'
                  print doc line
                %finish
              %finish
              -> d(name)
            %finish
          %finish
        %else %if '0' <= nextsym <= '9'
          read num(1)
          get terminator(foname)
          font = num;  font = dfbound %if font > dfbound
          select font(font)
          atomybias = fontybias %if fontybias > atomybias
          atomydisp = fontydisp %if fontydisp > atomydisp
        %else;  !escaped non-alphanumeric
          read sym
          atomlastsym = 1;  !to prevent recognition of eg period
          put sym(sym,disp,bold<<boldshift,under)
        %finish
      %else %if sym = closebracket
        end vintage
      %else;  !not escape or closebracket
        symcode = def(sym)
        %if symcode > 0 %start;  !single-char directive
          get terminator(0) %if bracket(nextsym) > ' '
          msp = msp+1;  macstack(msp) = macpos
          macpos = symcode
        %else;  !normal character
          %if symcode = letsym %start
            sym = sym!!invert
            %if sym > 'Z' %start
              sym = sym-cstate
              upper = -1 %if upper = 0
            %else 
              upper = 1 %if upper = 0
            %finish
          %else %if xatoms > 0 %and closebracket = -'W'
            xatoms = 0
            end vintage
          %finish
          atomlastsym = sym
          put sym(sym,disp,bold<<boldshift,under)
        %finish
      %finish
      read sym
    %repeat
  %repeat
  %return

%routine SKIP TO NUM(%integer unit)
  read sym %until sym < 'A';            !rest of mnemonic + '=' (or space)
  read num(unit)
%end   { skip to num }

%routine READ FONT INFO(%integer f)
%integer i,n1,n2
%integer bfont,scale,height,width,depth
%record(bfontinfo)%name B
  read sym %while nextsym = ' '
  %if nextsym < 'A' %start;       !numeric definition
    read num(0);  bfont = num
    %unless 0 < bfont <= bfbound %and bindex(bfont) ## nil %start
      rangefault;  bfont = 16
    %finish
    scale = unity
    height = 0;  depth = 0;  width = 0
    %cycle
      read sym %until sym # ' '
      %if sym&letmask = 'S' %start;  !Scale
        skip to num(unity);  scale = num
      %else %if sym&letmask = 'H';  !Height
        skip to num(vupi);  height = num
      %else %if sym&letmask = 'D';  !Depth
        skip to num(vupi);  depth = num
      %else %if sym&letmask = 'W';  !Width
        skip to num(hupi);  width = num
      %else
        %exit
      %finish
    %repeat
    define scaled font(f,bfont,scale,height,depth,width)
  %else
    n1 = 0;  n2 = 0
    %cycle
      read sym
      %exit %if sym <= ' '
      sym = sym-('a'-'A') %if 'a' <= sym <= 'z'
      n1 = n2 %and n2 = 0 %if n2>>24 # 0
      n2 = n2<<8+sym
    %repeat
    %while n1 = 0 %or n2>>24 = 0 %cycle
      n1 = n2 %and n2 = 0 %if n2>>24 # 0
      n2 = n2<<8+' '
    %repeat
    bfont = basic font(n1,n2,1);  !with auto-fetch
    %return %if bfont = 0
    b == bindex(bfont)
    %return %if b_type # 1;       !must be raster
    initialise derived font(f,b_ymax,b_ybias,b_width)
    define derived chars(f,bfont,33,33,95,unity)
  %finish
%end;   { read font info }

d('A'):                                 !assign
  %cycle
    read layout name
    assign(' ')
    faultpos = spos
    read sym
    %if sym # ';' %and sym # nl %start
      fault("Faulty format") %if name # 0
      read sym %until sym = ';' %or sym = nl
    %finish
  %repeat %until sym = nl
  linebreaker = 0
  invert = casebit %if invert # 0
  rangefault %and indent = 0 %if indent > tabbound %or tab(indent) >= line
  ->d('N') %if ignore # 0
  num = tab(indent)
setpos:
  %if num < line %start
    spacing = left+num-horpos
  %else
    fault("Off page")
  %finish
  lastsym = 0
  gaps = 0;  sgaps = 0;  lastgap = 0
  -> next
d('Z'):
  read num(1)
  skip one space
  penwidth = num
  -> next
d('X'):
  reset frame %if framestate # filling
  read num(1)
  %if relind # 0 %then num = num+horpos %else num = num+left
  num = left %if num < left;  num = linelim %if num > linelim
  hold = num;  num = verpos
  %if a(',') %start
    read num(1)
    %if relind # 0 %then num = num+verpos %else num = num+top
  %finish
  num = top %if num < top;  num = pagelim %if num > pagelim
  skip one space
!printsymbol('X');write(horpos,1);write(verpos,1);write(hold,1)
!write(num,1);write(penwidth,1);newline
  drawline(horpos,verpos,hold,num,penwidth) %if penwidth > 0
  horpos = hold;  verpos = num
  -> next
d('Y'):
  reset frame %if framestate # filling
  read num(1)
  %if relind # 0 %then num = num+verpos %else num = num+top
  num = top %if num < top;  num = pagelim %if num > pagelim
  hold = num;  num = horpos
  %if a(',') %start
    read num(1)
    %if relind # 0 %then num = num+horpos %else num = num+left
  %finish
  num = left %if num < left;  num = linelim %if num > linelim
  skip one space
!printsymbol('Y');write(horpos,1);write(verpos,1);write(num,1)
!write(hold,1);write(penwidth,1);newline
  drawline(horpos,verpos,num,hold,penwidth) %if penwidth > 0
  verpos = hold;  horpos = num
  -> next
d('O'):                                 !circle
  reset frame %if framestate # filling
  read num(1)
  skip one space
  circle(verpos,horpos,num)
  -> next
d('R'):                                 !row (num read)
  skip one space
  %if 0 <= num < page %then verpos = num+top %c
  %else fault("Out of bounds")
  -> next
d('B'):                                 !blanks
  reset doc line;                       ![esp HORPOS]
  read num(nls)
  skip one space
  %if verpos > top %or xpage # 0 %start
    verpos = verpos+num
    verpos = top %if verpos < top
    %if verpos >= pagelim %start
      verpos = pagelim
      close page;  reset doc line
    %finish
  %finish
  -> next
d('I'):                                 !indent
  read num(0)
  num = indent+num %if relind # 0
  %if indentused # 0 %then skip one space %c
  %else get terminator(iname)
  rangefault %and num = 0 %unless 0 <= num <= tabbound
  indent = num %if indentused = 0
  num = tab(num)
  ->setpos
d('J'):                                 !justify (done)
  skip one space
  -> next
d('L'):                                 !lines
  reset doc line;                       ![esp HORPOS]
  indentind = 0
  new vintage(-'L')
  read num(0)
  xlines = num;  xlines = -1 %if xlines = 0
  %cycle
    read sym
    %exit %if sym = nl
    name = 0
    %if 'A' <= sym&letmask <= 'Z' %start
      name = sym&letmask
    %else %if sym = escape
      %if a letter %start
        read name
        %if name <= tab0 %start;  !layout parameter
          assign(0)
          name = 0
        %else %if name >= 128;  !non-basic directive
          get terminator(0)
          i = def(name)
          %if i > 0 %start
            msp = msp+1;  macstack(msp) = macpos
            macpos = i
          %finish %else fault("Unknown directive")
          name = 0
        %finish
      %else %if '0' <= nextsym <= '9'
        read num(1)
        push value(foname)
        font = num;  font = dfbound %if font > dfbound
        select font(font)
        atomybias = fontybias %if fontybias > atomybias
      %finish
    %else
      fault("Faulty format") %if sym > ' '
    %finish
    %if name # 0 %start
      %if name = 'C' %start
        linecapind = casebit
      %else %if name = 'M'
        linemidind = 1
      %else %if name = 'I'
        indentind = \0
      %else %if name = 'H' %or name = 'B';    !heavy (bold)
        read num(1)
        num = boldsteps %if nonum # 0
        push value(hname)
        bold = num
      %else %if name = 'U';          !underline
        read num(1)
        num = unddisp %if nonum # 0
        push value(uname)
        under = num
      %else
        fault("Spurious directive")
      %finish
    %finish
  %repeat
  spacing = 0 %if indentind = 0
  -> next
d('N'):                                 !newpage
  skip one space
!  %if msp < 16 %start;  !within FORMAT
!    print page %if pages+1 >= start
!    verpos = top
!  %else;                !processing text
    close page;  reset doc line
!  %finish
  xpage = 1
  -> next
d('P'):                                 !paragraph
  read num(nls)
  skip one space
  %if verpos > top %start
    verpos = verpos+num
    verpos = top %if verpos < top
    %if verpos+nls+nls > pagelim %start
      verpos = pagelim
      close page;  reset doc line
      spacing = spacing+pgap
      -> next
    %finish
  %finish
  num = pgap+spacing
  ->setpos
d('T'):                                 !tab
  read num(0)
  skip one space
  %if relind # 0 %start
    t = 0;  c = horpos-left+spacing
    %if relind = '+' %start
      %while num > 0 %cycle
        t = t+1 %until t > tabbound %or tab(t) > c
        rangefault %and -> next %if t > tabbound
        c = tab(t)
        num = num-1
      %repeat
    %else
      t = t+1 %until t > tabbound %or tab(t) >= c
      %while num < 0 %cycle
        t = t-1 %until t < 0 %or tab(t) < c
        rangefault %and -> next %if t < 0
        c = tab(t)
        num = num+1
      %repeat
    %finish
  %else
    rangefault %and -> next %if num > tabbound
    c = tab(num)
  %finish
  num = c
  ->setpos
d('V'):                                 !verify
  read num(nls)
  skip one space
  %if verpos+num > pagelim %start
    close page;  reset doc line
    xpage = 1
  %finish
  -> next
d('M'):                                !mode
  read num(0)
  %if mode # num %start
    read sym %until sym = nl
  %finish
  -> next
d('F'):                                !Font
  read num(0)
  rangefault %and num = dfbound %unless 1 < num <= dfbound
  read sym %until sym # ' '
  -> next %if sym # '='
  read font info(num)
  -> next
d('G'):                                !Get file
  read num(0)
  read sym %until sym # ' '
  %if sym = nl %start
    %if msp >= 16 %then fault("Faulty format") %c
    %else %start
      switch contexts
      rot = 1<<6 %if num = 90
    %finish
  %else
    gname = "";  c = 0
    %cycle
      c = c<<8+sym!32
      gname = gname.tostring(sym)
      read sym
    %repeat %until sym <= ' '
    %if curin = 3 %then rangefault %else %start
      %if opened(gname) %start
        %if c # '.lay' %start
          %if c = '.pdf' %start
            num = unity
            read num(unity) %and read sym %if sym = ' '
            c = num
            num = 0
            read num(1) %and read sym %if sym = ' '
            t = num
            num = 0
            read num(1) %and read sym %if sym = ' '
            hold = num
            num = 1
            read num(1) %and read sym %if sym = ' '
            print vector file(c,t,hold,num)
          %else
            print gp
          %finish
          close input
          curin = curin-1;  select input(curin)
        %finish
      %finish
    %finish
  %finish
  -> next
d('D'):                         !Define
  read sym %until sym # ' '
  %if 'A' <= sym&letmask <= 'Z' %start
    read name
    name = 0 %if name < 128
  %else
    name = sym
  %finish
  %if name <= ' ' %or '0' <= name <= '9' %start
rep:
    fault("Faulty format")
    read sym %while sym # nl
    -> next
  %finish
  read sym %until sym # ' '
  -> rep %if sym # '='
  read sym %until sym # ' '
  %if sym = nl %then def(name) = 0 %else %start
    def(name) = macfree
    %cycle
      mac(macfree) = sym;  macfree = macfree+1
      read sym
    %repeat %until sym = nl
    mac(macfree) = 0;  macfree = macfree+1
  %finish
  -> next
!d('Z'):  !? define format
!  macstack(0) = macfree
!  read sym %until sym > ' '
!  %cycle
!    mac(macfree) = sym;  macfree = macfree+1
!    read sym
!  %repeat %until sym = escape %and nextsym!casebit = 'e'
!  mac(macfree) = 0;  macfree = macfree+1
!  read sym %until sym = nl
!  macstack(msp+1) = macpos
!  altmsp = msp
!  msp = 0
!  macpos = macstack(0)
!  -> next

d('H'): d('U'): d('W'): !(dealt with)
d('C'): d('K'):
d('Q'):
d('S'):
  fault("Unknown directive")
  -> next
d('E'):                                 !end
  close page %if framestate = 0
%end;  !PRINT LAYOUT FILE


%external %routine %spec print dvi file(%string(255) filename, 
                                        %integer %name pagesprinted)


!!!!!!!!!!!!!!!!!!!!!!!!!!!!  Main program  !!!!!!!!!!!!!!!!!!!!!!!!!!!!


%integer I,SCALE

%routine READ NUM(%integer mult)
  num = 0
  %cycle
    read symbol(sym)
    %exit %unless '0' <= sym <= '9'
    num = num*10+sym-'0'
  %repeat
  %if mult # 0 %start
    num = num*100
    %if sym = '.' %start
      read symbol(sym)
      %if '0' <= sym <= '9' %start
        num = num+10*(sym-'0')
        read symbol(sym)
        %if '0' <= sym <= '9' %start
          num = num+sym-'0'
          read symbol(sym)
        %finish
      %finish
    %finish
  %finish
%end

%routine LOOP
  read num(0)
  %cycle
    wait %if printing >= 0
    start printer
    num = num-1
  %repeat %until num <= 0
%end

!%include "I:FS.INC"
%routine FIND SPOOLED FILE
%integer i,j,k,kk,l;  %string(255) name
  %on %event 3,9 %start
    close input
    newline %if l # 0
    %return
  %finish
  %return %if spoolfiles > roguefiles
  open input(3,"LP1:DIRECTORY")
  select input(3)
  l = 0
  %while spoolfiles < maxspoolfiles %cycle
    name = ""
    read symbol(k) %until k > ' '
    kk = k
    %cycle
      name = name.tostring(k)
      read symbol(k)
    %repeat %until k <= '!'
    %if k # '!' %and kk # '$' %start
      printstring("LP1:") %and newline %if l = 0
      newline %and l = 0 %if l >= 49
      space %and l = l+1 %while l&15 # 0
      space;  l = l+1
      printstring(name);  l = l+length(name)
      j = 0
      j = j+1 %until j > roguefiles %or spooled(j) = name
      %if j > roguefiles %start
        spoolfiles = spoolfiles+1;  spooled(spoolfiles) = name
      %finish
    %finish
  %repeat
  close input
  newline %if l # 0
%end

%routine DELETE FILE
%integer i,j;  %string(31) name
%on %event 3,9 %start
  printstring(event_message);  newline
  name = spooled(spoolfiles)
  i = spoolfiles
  %cycle
    i = i-1
    %exit %if i = roguefiles
    spooled(i+1) = spooled(i)
  %repeat
  roguefiles = roguefiles+1
  spooled(roguefiles) = name
  %return
%finish
  printstring("Deleting ".fname);  newline
  delete(fname)
  spoolfiles = spoolfiles-1
%end

%routine PRINT FILE

  %integer ext,i

  reset macros
  reset globals
!*** for now -- in absence of decent fixed pitch font **
  define scaled font(2,16,250,0,0,0)
  select font(2)
  ext = 0
  ext = ext<<8+charno(fname,i)!32 %for i = 1,1,length(fname)
  %if ext = '.lay' %start
    print layout file(0)
  %else %if ext = '.dvi' 
    mark
    print dvi file(fname,pagesprinted)
    release
  %else %if ext = '.san' %or ext = '.vfx'
    print sanders file(0)
  %else %if ext = '.lis'
    print plain file(1,0,1,1)
  %else %if ext = '.pdf'
    scale = unity %unless 0 < scale < 100*unity
    reset frame %if framestate # filling
    print vector file(scale,0,0,0)
    print page
  %else
    print plain file(0,1,0,0)
  %finish
  %while curin > 0 %cycle
    close input
    curin = curin-1;  select input(curin)
  %repeat
%end

%integerfn TESTDELAY(%integer seconds)
%integer result
%owninteger noted=0
%constinteger cr=13

  %routine note(%string(255)s)
    printsymbol(cr); spaces(noted); printsymbol(cr)
    printstring(s); noted = length(s)
  %end

  %routine wait(%integer seconds,%integername ts)
  %integer deadline
    %cycle
      note(itos(seconds,2))
      deadline = cputime+1000
      %cycle
        ts = testsymbol
      %repeatuntil ts>=0 %or cputime>=deadline
      seconds = seconds-1
    %repeatuntil seconds<=0 %or ts>=0
  %end

  %routine disconnect
  %integer s,i
    %onevent 10 %start
      printstring("disconnect failed"); newline
      %return  {ignore disconnect errors}
    %finish
    note("closing")
    s = instream
    %for i = 1,1,3 %cycle
      selectinput(i); closeinput
    %repeat
    selectinput(s)
    note("disconnecting")
    disconnect host(host token)
    note("")
  %end

  %routine connect
  %owninteger dummy
    %onevent 10 %start
      printstring("connect failed: ")
      printstring(event_message)
      newline
      wait(30,dummy)
    %finish
    note("connecting")
    host token = connect to host(host string)
    note("")
  %end

! disconnect
  wait(seconds,result)
! connect
  %result = result
%end

%routine PS(%string(255) line)
  spaces(4);  printstring(line);  newline
%end

%routine log
  %on 3 %start
    selectoutput(0)
    printstring(event_message); newline
    openoutput(1,":n")
    selectoutput(1); closeoutput
    selectoutput(0)
    %return
  %finish
  open append(1,"text:.laserdb")
  select output(1)
  printstring(datetime)
  printsymbol(9)
  printstring(temp2)
  %if length(temp2)<8 %start
    printsymbol(9)
    printsymbol(32)
  %finish
  printsymbol(9)
  write(filesize(fname),0)
  printsymbol(9)
  write(pagesprinted,0)
  newline
  close output
  select output(0)
%end

%on %event 3,9 %start
  write(event_event,0); newline
  printstring(event_message); newline
  %stop 
%finish

  host string = filestorename(rdte)
  host string = hoststring."::TEXT,CRUDE"
  disconnect host(current host)
  host token = connect to host(host string)

  printstring(version); newline
  frame == array(heapget(framesize+16)+8)  { <--- MEGA HACK }
  FRAMEBASE1 = addr(frame(0))
  FRAMEBASE2 = FRAMEBASE1
  FRAMEBASE = framebase1;  
  FRAMELIM = framebase+framesize-framemult

  fname = ""
  fetch line fonts
  fetch raster fonts
  initialise store
  initialise raster fonts
  reset frame;  framestate = erased
  reslim = storefree
  reset macros
  reset globals
  %if fname # "@" %start
    select font(0)
    print gp %if opened("DOC:TFONTS.DEF")
    report("Times fonts:",tfonts)
    report("  Bytes:",storefree-storemin);  newline
    reslim = storefree
  %finish %else fname = ""

newcommand:

  %cycle
    copies = 1;  scale = unity
    curin = 0
    select input(0)
    set terminal mode(nopage)
    %cycle
      %cycle
        pagesprinted = 0
        find spooled file
        %exit %if spoolfiles <= roguefiles
        fname = "LP1:".spooled(spoolfiles)
        scale = unity
        curin = 0

        %if fname="LP1:STOP.NOW" %start
          delete file
          %stop
        %finish

        %if opened(fname) %start
          print file
          temp1 = fname
          temp1 -> ("LP1:").temp2
          log
          delete file
        %finish %else spoolfiles = spoolfiles-1
        fname = ""
        -> newcommand %if testsymbol >= nl
      %repeat
        -> newcommand %if testdelay(60) >= 0;  !one minute
    %repeat
  %repeat
%endofprogram