/****************************************************************************\
*                          Systems Research Group                            *
******************************************************************************


               #######   #######   ########  ##    ##  ########
               ########  ########  ########  ###   ##  ########
               ##    ##  ##    ##     ##     ####  ##     ##
               #######   ########     ##     ## ## ##     ##
               ##        #######      ##     ##  ####     ##
               ##        ##  ##       ##     ##  ####     ##
               ##        ##   ##   ########  ##   ###     ##
               ##        ##    ##  ########  ##    ##     ##


******************************************************************************
*   I. D. Wilson           Last Modified   -   IDW   -   16/01/87            *
\****************************************************************************/



//  Conditional compilation tags.  This program is designed to run on the
//  following machines:
//
//      TRIPOS                 Any Tripos machine
//      CAP1                   Cambridge CAP under CHAOS
//      MINOS                  Topexpress LSI4/95 under MINOS
//      PANOS                  Acorn 32016 under PANOS
//      ARM                    Acorn ARM under BRAZIL
//      VAXUNIX                Digital VAX under UNIX
//
//  The following composite tags imply:
//
//      COMMAND                Command name unknown, so LIST defines what the
//                             type of command is.
//
//      RDARGS                 Standard RDARGS is used to decode the argument
//                             string when the command is called.
//
//      DATSTRING              The way of obtaining the date and time is the
//                             Tripos (or Tripos-like) routine "datstring".
//
//      ESCAPE                 Whether '*E' is necessary to flush an output
//                             line.


$$COMMAND    :=  $$MINOS  |  $$PANOS  |  $$ARM

$$RDARGS     :=  ~$$VAXUNIX

$$DATSTRING  :=  $$TRIPOS  |  $$MINOS  |  $$PANOS

$$ESCAPE     :=  $$TRIPOS  |  $$MINOS  |  $$CAP1



SECTION "PRINT"


GET "LIBHDR"


$<TRIPOS    GET "CLIHDR"         $>TRIPOS
$<CAP1      GET ".bcpl.tripos"   $>CAP1
$<VAXUNIX   GET "tripos.b"       $>VAXUNIX



$<VAXUNIX
MANIFEST
$(
    ug                    =  firstfreeglobal
$)
$>VAXUNIX



GLOBAL
$(
    aborted               :  ug + 0
    blib.rdch             :  ug + 1
    blib.unrdch           :  ug + 2
    columnpermember       :  ug + 3
    commandname           :  ug + 4
    d.default             :  ug + 5
    d.vdu                 :  ug + 6
    datestring            :  ug + 7
    debugging             :  ug + 8
    endoffile             :  ug + 9
    filename              :  ug + 10
    indexing              :  ug + 11
    indexlist             :  ug + 12
    inputco               :  ug + 13
    linebuffer            :  ug + 14
    linelength            :  ug + 15
    linenumber            :  ug + 16
    lineoffset            :  ug + 17
    linequeue             :  ug + 18
    linespercolumn        :  ug + 19
    listcommand           :  ug + 20
    maxcolumns            :  ug + 21
    maxtotalwords         :  ug + 22
    mincolumns            :  ug + 23
    name.standardinput    :  ug + 24
    name.standardoutput   :  ug + 25
    naming                :  ug + 26
    namingset             :  ug + 27
    newpagepending        :  ug + 28
    numbering             :  ug + 29
    opentitle             :  ug + 30
    outputco              :  ug + 31
    outputfile            :  ug + 32
    page.waiting          :  ug + 33
    pagefactor            :  ug + 34
    pagelength            :  ug + 35
    pagename              :  ug + 36
    pagenumber            :  ug + 37
    pagepermember         :  ug + 38
    pagepointer           :  ug + 39
    paging                :  ug + 40
    postscript            :  ug + 41
    postscriptcount       :  ug + 42
    postscriptflag        :  ug + 43
    printers              :  ug + 44
    printertype           :  ug + 45
    prolog                :  ug + 46
    returncode            :  ug + 47
    readnumber            :  ug + 48
    scbqueue              :  ug + 49
    separation            :  ug + 50
    spreading             :  ug + 51
    spacecount            :  ug + 52
    standardinput         :  ug + 53
    standardoutput        :  ug + 54
    stringbuff            :  ug + 55
    stringbuffb           :  ug + 56
    stringbuffe           :  ug + 57
    syserr                :  ug + 58
    sysin                 :  ug + 59
    sysout                :  ug + 60
    syswrch               :  ug + 61
    timestring            :  ug + 62
    title                 :  ug + 63
    titling               :  ug + 64
    totalwords            :  ug + 65
    truncating            :  ug + 66
    underlining           :  ug + 67
    waitstring            :  ug + 68
$)



MANIFEST
$(
    le.link               =  0
    le.overprint          =  1
    le.linenumber         =  2
    le.offset             =  3
    le.chars              =  4
    le.size               =  4

    ie.link               =  0
    ie.pagenumber         =  1
    ie.filename           =  2
    ie.size               =  2

    fl.link               =  0
    fl.name               =  1
    fl.special            =  2
    fl.scb                =  3
    fl.size               =  4

    p.link                =  0
    p.name                =  1
    p.printer             =  2
    p.options             =  3
    p.size                =  3

    columnspacing         =  2
    numberwidth           =  7
    titledepth            =  2

    minlinelength         =  10
    maxlinelength         =  500
    minpagelength         =  10
    maxpagelength         =  500
    mincolumnwidth        =  minlinelength

    maxpostscriptcount    =  100

    linebufferlength      =  255

$<ARM'
    NIL                   =  -1
$>ARM'

    print.toolong         =  -2
    print.newpage         =  -3
    print.end             =  -4

    a.file                =  0
    a.to                  =  1
    a.opt                 =  2

$<TRIPOS
    co.stacksize          =  500
$>TRIPOS

    error.nospace         =  103        //  Error.getvecfailure in MANHDR
$)



LET start( unix.argc, unix.argv, unix.envp )  BE
$(
//  General purpose multi column print program.  Options to the
//  program are:
//
//      C=n         Set number of columns
//      MC=n        Set maximum number of columns
//      S=n         Set separation of columns to "n"
//      SPREAD      Spread the columns if room
//      NOSPREAD    Do not spread the columns
//      TITLE=t     Set page title
//      NOTITLE     No page titles
//      U           Underline page titles
//      NOU         Don't underline page titles
//      L=n         Set page length
//      W=n         Set page width
//      LN          Print line numbers
//      NOLN        Don't print line numbers
//      LO=n        Set line offset
//      PN          Print page numbers
//      NOPN        Don't print page numbers
//      PW=s        Page wait with string "s"
//      NOPW        Don't page wait
//      PM          New page per output member
//      CM          New column per output member
//      N           Print file names
//      NN          Do not print file names
//      TR          Truncate overlong lines
//      NOTR        Wrap overlong lines
//      PF[=]n      Set page factor to "n"
//      INDEX       Print an index of files
//      NOINDEX     Do not print an index of files
//      POSTSCRIPT  Print the output in "postscript" format
//      PROLOG[=]f  Send prolog file "f"
//      DEBUG       Print debugging information
//
//  Options for printers are read from the printer definitions file, which
//  is held in the following places:

$<TRIPOS    LET printfile.sys   =  "sys:info.printers"         $>TRIPOS
$<CAP1      LET printfile.sys   =  ".**.idw.printers"          $>CAP1
$<MINOS     LET printfile.sys   =  "dh1:users.idw.printers"    $>MINOS
$<PANOS     LET printfile.sys   =  "$.idw.printers"            $>PANOS
$<ARM       LET printfile.sys   =  "$.idw.printers"            $>ARM
$<VAXUNIX   LET printfile.sys   =  "/etc/printoptions"         $>VAXUNIX

//  Printer definitions which are local to the current user are read from
//  a file which is held in the following places:

$<TRIPOS    LET printfile.user  =  "home:printers"             $>TRIPOS
$<CAP1      LET printfile.user  =  ".printers"                 $>CAP1
$<MINOS     LET printfile.user  =  "#.printers"                $>MINOS
$<PANOS     LET printfile.user  =  "&.printers"                $>PANOS
$<ARM       LET printfile.user  =  "&.printers"                $>ARM
$<VAXUNIX   LET printfile.user  =  ".printoptions"             $>VAXUNIX

$<VAXUNIX
    LET unix.optb  =  VEC 256/bytesperword
    LET unix.optl  =  0
    LET unix.argn  =  1
$>VAXUNIX

$<RDARGS
    LET args       =  "FILE,TO/K,OPT/K"
    LET argv       =  VEC 50

    LET rdargs.ch  =  0
    LET rdargs.ok  =  0
$>RDARGS

$<DATSTRING
    LET datv       =  VEC 15
$>DATSTRING

$<VAXUNIX
    LET datevec    =  VEC 2
    LET timevec    =  VEC 2
$>VAXUNIX

    LET file       =  0
    LET options    =  0
    LET tofile     =  0
    LET instream   =  0
    LET outstream  =  0

    sysin           :=  input()
    sysout          :=  output()
    syswrch         :=  wrch

$<VAXUNIX
    syserr          :=  journal
$>VAXUNIX

$<VAXUNIX'
    syserr          :=  sysout
$>VAXUNIX'

    blib.rdch       :=  rdch
    blib.unrdch     :=  unrdch

    totalwords      :=  0
    maxtotalwords   :=  0
    returncode      :=  0

    //  Set up the flags and names for the standard input and output
    //  streams.

    standardinput        :=  FALSE
    standardoutput       :=  FALSE

    name.standardinput   :=  "{input}"
    name.standardoutput  :=  "{output}"

    //  Stop, if we do not have an input and output stream.

    IF  sysin = 0  |  sysout = 0  |  syserr = 0  THEN  stop( 9999 )

    //  Before anything, decide on whether we are the "PRINT" or "LIST"
    //  program.  This is done by looking at what the command we were
    //  loaded with is (yuck).

$<CAP1      stringinput( command.line )       $>CAP1
$<TRIPOS    stringinput( cli.commandname )    $>TRIPOS
$<VAXUNIX   stringinput( unix.argv!0 )        $>VAXUNIX

$<COMMAND
  $<LIST    stringinput( "LIST" )             $>LIST
  $<LIST'   stringinput( "PRINT" )            $>LIST'
$>COMMAND

    listcommand  :=  islist()
    commandname  :=  listcommand  ->  "LIST", "PRINT"

    endstringinput()

$<RDARGS
    //  Read the command line using "rdargs".  Usually, the arguments are
    //  read from the current input stream.  On CAP, this is different...

  $<CAP1
    stringinput( command.line )

    rdargs.ch  :=  rdch()  REPEATUNTIL  isterminator( rdargs.ch )

    unrdch()
  $>CAP1

    //  We are now at the end of the command line, so we can look to
    //  see if the arguments match up to what we expect.

    rdargs.ok  :=  rdargs( args, argv, 50 )

  $<CAP1
    endstringinput()
  $>CAP1

    UNLESS  rdargs.ok  DO
    $(
        errormessage( "Bad arguments for string *"%S*"", args )

        stop( returncode )
    $)

    //  Pick up the arguments which we have read.

    file     :=  argv!a.file
    tofile   :=  argv!a.to
    options  :=  argv!a.opt
$>RDARGS

$<VAXUNIX
    //  On UNIX systems, the argument decoding is done rather differently,
    //  so as to fit in with the usual conventions.

    UNTIL  unix.argn > unix.argc  DO
    $(
        LET arg   =  unix.argv!unix.argn
        LET argl  =  arg % 0

        IF  argl > 1  THEN

            //  This could be an option, or a command to set the output
            //  file to somewhere different.

            IF  arg % 1  =  '-'  THEN
            $(
                //  Which is it?  If it is the "-to" option, then handle
                //  that first.

                TEST  compstring( arg, "-to" ) = 0  THEN

                    //  We should send the output to a file, so make sure
                    //  that this is not the last argument on the line.

                    UNLESS  unix.argn = unix.argc  DO
                    $(
                        unix.argn  :=  unix.argn + 1
                        tofile     :=  unix.argv!unix.argn
                    $)

                ELSE
                $(
                    //  This is an option, which must be concatenated with
                    //  the option we have already read.

                    UNLESS  unix.optl = 0  DO
                    $(
                        unix.optl              :=  unix.optl + 1
                        unix.optb % unix.optl  :=  ','
                    $)

                    FOR  i = 2  TO  argl  DO
                        unix.optb % (unix.optl + i - 1)  :=  arg % i

                    unix.optl  :=  unix.optl + argl - 1
                $)

                //  Whatever else, if this is an option, then we have not
                //  hit the file arguments yet.

                unix.argn  :=  unix.argn + 1

                LOOP
            $)

        //  If we drop through here, then we have hit something which
        //  is not an option.  We therefore assume that it is a file
        //  argument.

        BREAK
    $)

    //  When we drop out of that loop, we have picked up all the option
    //  strings and joined them together.  We also know where the file
    //  names start.

    unix.optb % 0  :=  unix.optl

    //  Set up the variables needed later on.  "tofile" is already set, and
    //  "file" is not needed until later.  The only one which has any meaning,
    //  therefore, is "options".

    UNLESS  unix.optl = 0  DO  options  :=  unix.optb

    //  The user's print option file must now be found.  We look at the home
    //  directory, and concatenate the default name onto the end.

    UNTIL  !unix.envp = 0  DO
    $(
        LET userpfl  =  printfile.user % 0

        LET prefix   =  "HOME="
        LET prefixl  =  prefix % 0

        LET string   =  !unix.envp
        LET stringl  =  string % 0

        LET buffer   =  0
        LET bufferl  =  0
        LET bufferp  =  0

        FOR  i = 1  TO  prefixl  DO
            UNLESS  string % i  =  prefix % i  DO
                GOTO  nextstring

        //  If we drop out of that loop, then we have found the correct
        //  prefix value.  Make a copy of the new file name for later.
        
        bufferl     :=  stringl - prefixl + userpfl + 1

        buffer      :=  getvector( bufferl/bytesperword )
        buffer % 0  :=  bufferl

        FOR  i = 1  TO  stringl-prefixl  DO
            buffer % i  :=  string % (prefixl + i)

        bufferp           :=  stringl - prefixl + 1
        buffer % bufferp  :=  '/'

        FOR  i = 1  TO  userpfl  DO
            buffer % (bufferp + i)  :=  printfile.user % i

        //  Having copied the string, we can now set the user print file
        //  to point to it, and abandon the search of the environment.
        
        printfile.user  :=  buffer
        
        GOTO  foundroot

        //  If we come here, then we have not found the prefix yet, so
        //  keep on looking.

    nextstring:

        unix.envp  :=  unix.envp + 1
    $)

    //  If we drop out of there, then we have not found the root directory
    //  in the environment.  We must still copy the user file name into heap
    //  since it is to be freed later.

    printfile.user  :=  copystring( printfile.user )

foundroot:

    //  The user print file is now copied into heap memory, and (hopefully)
    //  corresponds to a file in the user's root directory.
$>VAXUNIX

    //  Set up default options.

    mincolumns       :=  1
    maxcolumns       :=  8
    lineoffset       :=  0
    pagefactor       :=  1
    separation       :=  columnspacing
    numbering        :=  listcommand
    titling          :=  listcommand
    indexing         :=  FALSE
    naming           :=  FALSE
    namingset        :=  FALSE
    underlining      :=  FALSE
    paging           :=  FALSE
    pagepermember    :=  FALSE
    columnpermember  :=  FALSE
    truncating       :=  FALSE
    debugging        :=  FALSE
    postscript       :=  FALSE
    postscriptflag   :=  FALSE
    newpagepending   :=  TRUE
    spreading        :=  TRUE
    title            :=  NIL
    waitstring       :=  NIL
    outputfile       :=  NIL
    opentitle        :=  NIL
    prolog           :=  NIL

    page.waiting     :=  "Page waiting ... "

    linequeue        :=  NIL
    scbqueue         :=  NIL
    printers         :=  NIL
    pagepointer      :=  NIL
    indexlist        :=  NIL

    linebuffer       :=  getvector( linebufferlength / bytesperword )

    pagenumber       :=  0
    postscriptcount  :=  0
    spacecount       :=  0
    aborted          :=  FALSE

    //  Read the printer definition files, and keep the resulting data
    //  structure in store.  We allow the user file to override the system
    //  definitions.

    printers  :=  readprinters( printfile.sys,  NIL )
    printers  :=  readprinters( printfile.user, printers )

$<VAXUNIX
    freevector( printfile.user )
$>VAXUNIX

    //  Set up characteristics for the default printer, and then decode
    //  the options as given to us.

    d.default  :=  lookupprinter( "DEFAULT" )
    d.vdu      :=  lookupprinter( "VDU" )

    IF  d.default = NIL  THEN
        errormessage( "No definition for *"DEFAULT*" in %S or %S",
                       printfile.sys, printfile.user )

    IF  d.vdu = NIL  THEN
        errormessage( "No definition for *"VDU*" in %S or %S",
                       printfile.sys, printfile.user )

    //  If we don't have those important printers, then we had better stop
    //  now!

    IF  d.default = NIL  |  d.vdu = NIL  THEN  GOTO  endoffiles

    //  Now, scan the list of options we have been given to see if we find
    //  a printer definition among them.  If not, then we should set the
    //  default printer options.

    UNLESS  scanforprinter( printers, options )  DO  setprinter( d.default )

    //  Having decided that, scan the options, this time making note of them.

    UNLESS  options = 0  DO  decodeoptions( options, TRUE )

    //  If we have been asked to send output to an explicit file, then
    //  we must override the name of the device.

    TEST  tofile = 0  THEN
    $(
        //  No output file, so set the printer up as output.  We should
        //  add the file name to the printer name, if this has been
        //  requested by the user.

        LET filename  =  file  \= 0  ->  file,  NIL

        LET printer   =  printertype!p.printer
        LET printerl  =  printer % 0

        LET buffer    =  getvector( 256/bytesperword )
        LET length    =  0

        LET pos       =  0
        LET ch        =  0

        //  Substitute the file name and the open title if this has been
        //  requested by the user.

        UNTIL  pos = printerl  DO
        $(
            pos  :=  pos + 1
            ch   :=  printer % pos

            TEST  ch = '?'  THEN
            $(
                //  This is an option which we should respond to.  The
                //  Following options are understood:
                //
                //      ??      ?
                //      ?T      Title (or file name)
                //      ?N      Newline

                IF  pos = printerl  THEN
                $(
                    errormessage( "Dangling *"?*" in printer name" )

                    BREAK
                $)

                pos  :=  pos + 1
                ch   :=  uppercase( printer % pos )

                TEST  ch = '?'  |  ch = 'N'  THEN
                $(
                    //  Simple ? or *N character.  Put it into the output
                    //  buffer, and continue.

                    length           :=  length + 1
                    buffer % length  :=  ch = '?'  ->  '?',  '*N'
                $)
                ELSE

                TEST  ch = 'T'  THEN
                $(
                    //  File name or title substitution.

                    LET string  =  opentitle = NIL  ->  filename, opentitle

                    UNLESS  string = NIL  DO

                        //  String to be substituted, so do that here.

                        FOR  j = 1  TO  string % 0  DO
                        $(
                            length           :=  length + 1
                            buffer % length  :=  string % j
                        $)
                $)
                ELSE

                    //  Erroneous situation here chaps, since we don't
                    //  understand the character after the '?'.

                    errormessage( "Unknown *"?%C*" in printer name", ch )
            $)
            ELSE
            $(
                //  Simple character, so copy it across into the output buffer
                //  and go round for more.

                length           :=  length + 1
                buffer % length  :=  ch
            $)
        $)

        //  When we drop out of that, the buffer contains the full name
        //  to be used when opening the printer.

        buffer % 0  :=  length
        outputfile  :=  buffer
    $)
    ELSE  outputfile  :=  copystring( tofile )

    //  Unless we have done all that parsing correctly, we should stop
    //  here and now.

    UNLESS  returncode = 0  DO  GOTO  endoffiles

    //  Look at the name of the output file to see whether it is the
    //  standard output stream.  If so, then make a note of this now.

    standardoutput  :=  compstring( outputfile, name.standardoutput ) = 0

    //  Initialise the essential variables for the print run.  Read the
    //  date and time, since we will need these for the page headings.

$<CAP1
    datestring  :=  date()
    timestring  :=  time()
$>CAP1

$<DATSTRING
    datstring( datv )

    datestring  :=  datv + 0
    timestring  :=  datv + 5
$>DATSTRING

$<ARM
    datestring  :=  "dd-mmm-yy"
    timestring  :=  "hh:mm:ss"
$>ARM

$<VAXUNIX
    date( datevec )
    timeofday( timevec )

    datestring  :=  datevec
    timestring  :=  timevec
$>VAXUNIX

    IF  datestring % 1 = '0'  THEN  datestring % 1  :=  '*S'

    datestring % 3  :=  '*S'
    datestring % 7  :=  '*S'

    IF  timestring % 1 = '0'  THEN  timestring % 1  :=  '*S'

    timestring % 0  :=  5
    timestring % 3  :=  '.'

    IF  debugging  THEN
        message( "Output = *"%S*"  Date = *"%S*"  Time = *"%S*"",
                  outputfile, datestring, timestring )

$<VAXUNIX
    //  Under UNIX, the files to be printed appear as part of the "argv"
    //  buffer.

    TEST  unix.argn > unix.argc  THEN  openfile( @scbqueue, name.standardinput )
    ELSE

        FOR  i = unix.argn  TO  unix.argc  DO
        $(
            LET filename  =  unix.argv!i

            openfile( @scbqueue, filename )
        $)
$>VAXUNIX

$<RDARGS
    //  Systems which use "rdargs" only have one file argument, and this
    //  should be tested now.

    TEST  file = 0
        THEN  openfiles( @scbqueue, TRUE )
        ELSE  openfile( @scbqueue, file )
$>RDARGS

    //  Set the "naming" option, if it hasn't been done already.

    UNLESS  namingset  DO
        naming  :=  countscbs( scbqueue ) > 1

    //  The files have now been read.  If there is nothing to print, then just
    //  finish now, otherwise open the output stream.

    UNLESS  scbqueue = NIL  |  aborted  DO
    $(
        //  Before opening the output stream, look to see if there is a prolog
        //  file which must be sent.  If so, open it, to make sure that it
        //  exists.

        LET stream  =  0

        UNLESS  prolog = NIL  DO
        $(
            stream  :=  findinput( prolog )

            IF  stream = 0  THEN
            $(
                //  Failed to open the PROLOG file, so complain.

                errormessage( "Cannot open PROLOG file *"%S*"", prolog )

                GOTO  endoffiles
            $)
        $)

        //  Now, attempt to open the printer itself.  When this has been done,
        //  we can dump the prolog file down to it.

        outstream  :=  standardoutput  ->  sysout,  findoutput( outputfile )

        IF  outstream = 0  THEN
        $(
            //  Failed to open the printer stream.  Not a lot we can do here
            //  chaps, so just close down.

            UNLESS  stream = 0  DO
            $(
                selectinput( stream )
                endread()
            $)

            errormessage( "Cannot open PRINTER *"%S*"", outputfile )

            GOTO  endoffiles
        $)

        //  The output stream is open, so start sending something down it.

        selectoutput( outstream )

        //  Send the prolog file down, if one has been given.

        UNLESS  stream = 0  DO
        $(
            //  There is a prolog file, so we should handle it here.  Copy
            //  it down to the printer without any interpretation of the
            //  characters.

            LET ch  =  0

            selectinput( stream )

            ch  :=  rdch()

            UNTIL  ch = endstreamch  DO
            $(
                wrch( ch )

                ch  :=  rdch()
            $)

            endread()

            selectinput( sysin )
        $)

        IF  postscript  THEN
        $(
            writeprolog()

            writes( "true pf*N" )

            wrch  :=  pswrch
        $)

$<TRIPOS'
        //  Under anything other than TRIPOS, there is no point in
        //  interleaving input and output, so run the two sequentially.

        printinput()
$>TRIPOS'

$<TRIPOS
        //  The output stream and all the input streams are open.  This means
        //  that we can create the input and output coroutines, and start the
        //  ball rolling.

        inputco   :=  createco( printinput,  co.stacksize )
        outputco  :=  createco( printoutput, co.stacksize )

        IF  inputco = 0  |  outputco = 0  THEN  abort( error.nospace )

        print( input(), output() )

        deleteco( inputco )
        deleteco( outputco )
$>TRIPOS

        IF  postscript  THEN
        $(
            wrch  :=  syswrch

            writes( "false pf*N" )
            writes( "newpage pagesave restore*N" )

            writes( "%%Trailer*N" )
            writef( "%%%%Pages:  %N*N", pagenumber )
        $)

        UNLESS  standardoutput  DO  endwrite()
    $)

endoffiles:

    selectinput( sysin )
    selectoutput( sysout )

    wrch  :=  syswrch

    //  Free any SCBs which are on the queue of files yet to be printed.

    UNTIL  scbqueue = NIL  DO
    $(
        LET next     =  scbqueue!fl.link
        LET name     =  scbqueue!fl.name
        LET special  =  scbqueue!fl.special
        LET scb      =  scbqueue!fl.scb

        freevector( name )
        freevector( scbqueue )

        UNLESS  special  |  scb = NIL  DO
        $(
            selectinput( scb )
            endread()
        $)

        scbqueue  :=  next
    $)

    //  Free any lines which are queued up for printing

    UNTIL  linequeue = NIL  DO  freeline( dequeueline() )

    //  Free the index data structure.

    UNTIL  indexlist = NIL  DO
    $(
        LET link  =  indexlist!ie.link

        freevector( indexlist!ie.filename )
        freevector( indexlist )

        indexlist  :=  link
    $)

    //  And dismantle the printer data structure.

    UNTIL  printers = NIL  DO
    $(
        LET link  =  printers!p.link

        freevector( printers!p.name )
        freevector( printers!p.printer )
        freevector( printers!p.options )
        freevector( printers )

        printers  :=  link
    $)

    UNLESS  title = NIL       DO  freevector( title )
    UNLESS  opentitle = NIL   DO  freevector( opentitle )
    UNLESS  waitstring = NIL  DO  freevector( waitstring )
    UNLESS  prolog = NIL      DO  freevector( prolog )
    UNLESS  outputfile = NIL  DO  freevector( outputfile )

    freevector( linebuffer )

    IF  debugging  THEN
        message( "Space allocated:     %N words", totalwords )

    IF  debugging  THEN
        message( "Maximum space used:  %N words", maxtotalwords )

    stop( returncode )
$)



AND writeprolog()  BE
$(
//  Calculate the orientation and font size which we should use for this
//  run.  We then print these out as a postscript prolog.

    MANIFEST
    $(
        xpoints  =  (595 - 72) * 10
        ypoints  =  (841 - 72) * 10
    $)

    LET xl  =  xpoints/linelength
    LET xp  =  xpoints/pagelength

    LET yl  =  ypoints/linelength
    LET yp  =  ypoints/pagelength

    LET ap  =  aspect( xl, yp )
    LET al  =  aspect( yl, xp )

    LET dp  =  ABS( 6 - ap )
    LET dl  =  ABS( 6 - al )

    LET x1  =  0
    LET x2  =  0
    LET y1  =  0
    LET y2  =  0

    LET pt  =  0

    //  We choose the orientation depending on the ratio of the values which
    //  we have just calculated.  The criterion is that the aspect ratio
    //  be closest to "0.6".

    TEST  dp < dl  THEN
    $(
        //  The characters have the correct aspect ratio in the portrait
        //  mode.  We should choose this one.

        xl  :=  (xl * 10)/6

        x1  :=  xl  /  10
        x2  :=  xl REM 10

        y1  :=  yp  /  10
        y2  :=  yp REM 10

        pt  :=  TRUE
    $)
    ELSE
    $(
        //  The characters have the correct aspect ratio in the landscape
        //  mode.  We should choose this one.

        yl  :=  (yl * 10)/6

        x1  :=  yl  /  10
        x2  :=  yl REM 10

        y1  :=  xp  /  10
        y2  :=  xp REM 10

        pt  :=  FALSE
    $)

    writef( "/linedepth %N.%N def*N", y1, y2 )
    writef( "%S*N", pt -> "pt", "ls" )
    writef( "(Courier) findfont [%N.%N 0 0 %N.%N 0 0] makefont setfont*N",
             x1, x2, y1, y2 )
$)



AND aspect( x, y )  =  (x * 10)/y



AND countscbs( list )  =  VALOF
$(
//  Return the number of scbs in the list.

    LET count  =  0

    UNTIL  list = NIL  DO
    $(
        count  :=  count + 1

        list   :=  list!fl.link
    $)

    RESULTIS  count
$)



AND freeline( line )  BE  UNTIL  line = NIL  DO
$(
    LET op  =  line!le.overprint

    freevector( line )

    line  :=  op
$)



$<TRIPOS
AND print( inputstream, outputstream )  BE
$(
//  Routine to handle the scheduling of the two coroutines for TRIPOS.

    LET blibpktwait  =  pktwait
    LET inpkt        =  0
    LET outpkt       =  0
    LET in.in        =  0
    LET in.out       =  0
    LET out.in       =  0
    LET out.out      =  0

    pktwait  :=  copktwait

    selectinput( inputstream )
    selectoutput( outputstream )

    inpkt    :=  callco( inputco )

    in.in    :=  input()
    in.out   :=  output()

    selectinput( inputstream )
    selectoutput( outputstream )

    outpkt   :=  callco( outputco )

    out.in   :=  input()
    out.out  :=  output()

    UNTIL  inpkt = NIL  &  outpkt = NIL  DO
    $(
        LET pkt  =  taskwait()

        IF  pkt = inpkt  THEN
        $(
            selectinput( in.in )
            selectoutput( in.out )

            inpkt   :=  callco( inputco, pkt )

            in.in   :=  input()
            in.out  :=  output()

            LOOP
        $)

        IF  pkt = outpkt  THEN
        $(
            selectinput( out.in )
            selectoutput( out.out )

            outpkt   :=  callco( outputco, pkt )

            out.in   :=  input()
            out.out  :=  output()

            LOOP
        $)

        //  If it wasn't one of those, then HELP!

        abort( 9999 )
    $)

    pktwait  :=  blibpktwait
$)
$>TRIPOS



AND openfiles( scblist, prompting )  BE
$(
//  Take the names of files from the current input stream, and add control
//  blocks for these file onto the end of "scblist".

    MANIFEST
    $(
        a.file  =  0
    $)

    IF  prompting  &  NOT standardoutput  THEN
    $(
        LET o  =  output()

        selectoutput( sysout )
        writes( "Enter list of files, terminated by *"/***"*N" )
        selectoutput( o )
    $)

    $(  //  Repeat loop to read file names from the file, and open them.

        LET args  =  "FILE"
        LET argv  =  VEC 50
        LET file  =  0
        LET ch    =  0

        IF  prompting  &  NOT standardoutput  THEN
        $(
            LET o  =  output()

            selectoutput( sysout )

$<VAXUNIX
            prompt( ": " )
$>VAXUNIX

$<VAXUNIX'
            writes( ": " )
            flushoutput()
$>VAXUNIX'

            selectoutput( o )
        $)

        ch  :=  rdch()  ;  unrdch()

        IF  ch = endstreamch  THEN  BREAK

$<TRIPOS
        IF  testflags( #B0001 )  THEN
        $(
            //  Break.  Set the "aborted" flag.

            errormessage( "BREAK." )

            aborted    :=  TRUE

            RETURN
        $)
$>TRIPOS

$<MINOS
        IF  testflags( #B0001 )  THEN
        $(
            //  Break.  Set the "aborted" flag.

            errormessage( "BREAK." )

            aborted    :=  TRUE

            RETURN
        $)
$>MINOS

        UNLESS  string.rdargs( args, argv, 50 )  DO
        $(
            errormessage( "Arguments are of the form *"%S*"", args )

            LOOP
        $)

        file  :=  argv!a.file

        IF  file = 0  THEN  LOOP

        //  Check for the end of list marker:  "/*"

        IF  compstring( file, "/**" ) = 0  THEN  BREAK

        //  Otherwise, open the file.

        openfile( scblist, file )
    $)
    REPEAT  //  Until an end of list marker has been found.
$)



$<ESCAPE
AND flushoutput()  BE  wrch( '*E' )
$>ESCAPE

$<ESCAPE'
AND flushoutput()  BE  RETURN
$>ESCAPE'



AND openfile( scblist, name )  BE
$(
//  Open a file name, dealing with indirections as well.

    LET indirect  =  FALSE
    LET scb       =  0
    LET special   =  0

    IF  name % 1 = '!'  THEN
    $(
        //  This is an indirection, so shuffle the characters in the name down
        //  by one, and then open the files within this one.

        LET length  =  name % 0

        FOR  i = 2  TO  length  DO  name % (i - 1)  :=  name % i

        name % 0  :=  length - 1

        indirect  :=  TRUE
    $)

    //  Now, we can open the file, which is the same whether there is an
    //  indirection or not.

    special  :=  compstring( name, name.standardinput ) = 0
    scb      :=  special  ->  sysin,  findinput( name )

    TEST  scb = 0  THEN  errormessage( "Cannot open *"%S*"", name )
    ELSE

    TEST  indirect  THEN
    $(
        LET i  =  input()

        selectinput( scb )
        openfiles( scblist, FALSE )

        UNLESS  special  DO  endread()

        selectinput( i )
    $)
    ELSE
    $(
        LET entry  =  getfileentry()

        entry!fl.link     :=  NIL
        entry!fl.name     :=  copystring( name )
        entry!fl.special  :=  special
        entry!fl.scb      :=  putscb( scb, special )

        UNTIL  scblist!fl.link = NIL  DO  scblist  :=  scblist!fl.link

        scblist!fl.link  :=  entry
    $)
$)



AND printinput()  =  VALOF
$(
//  Main print routine.  Open the first file in the chain, and then set
//  the ball rolling.

    LET link  =  scbqueue!fl.link
    LET name  =  scbqueue!fl.name

    selectinput( getscb( scbqueue ) )

    freevector( scbqueue )

    filename  :=  name
    scbqueue  :=  link

    IF  naming  THEN  generatename( filename )

    addindex( filename, pagenumber )

    printfiles()
    endinput()

    RESULTIS  NIL
$)



AND printfiles()  BE
$(
//  Print the list of files.  Check that the options we have been given
//  make sense, and assuming they do, attempt to print the first file.

    IF  linelength < minlinelength  THEN
    $(
        errormessage( "Line length %N too small  -  set to %N",
                       linelength, minlinelength )

        linelength  :=  minlinelength
    $)

    IF  linelength > maxlinelength  THEN
    $(
        errormessage( "Line length %N too large  -  set to %N",
                       linelength, maxlinelength )

        linelength  :=  maxlinelength
    $)

    IF  (linelength - lineoffset) < mincolumnwidth  THEN
    $(
        LET actual  =  linelength - mincolumnwidth

        errormessage( "Line offset %N too large  -  set to %N",
                       lineoffset, actual )

        lineoffset  :=  actual
    $)

    //  Check the page length value.  We allow the special "P=0" to mean
    //  "do not insert any page throws".

    IF  pagelength < minpagelength  &  pagelength \= 0  THEN
    $(
        errormessage( "Page length %N too small  -  set to %N",
                      pagelength, minpagelength )

        pagelength  :=  minpagelength
    $)

    IF  pagelength > maxpagelength  THEN
    $(
        errormessage( "Page length %N too large  -  set to %N",
                       pagelength, maxpagelength )

        pagelength  :=  maxpagelength
    $)

    IF  mincolumns = 0  |  maxcolumns = 0  THEN
    $(
        errormessage( "Illegal number of columns  -  set to *"C=1*"" )

        mincolumns  :=  1
        maxcolumns  :=  1
    $)

    IF  (linelength / mincolumns) < mincolumnwidth  THEN
    $(
        LET actual  =  linelength / mincolumnwidth

        errormessage( "Too many columns: %N  -  set to %N",
                       mincolumns, actual )

        mincolumns  :=  actual
    $)

    //  Assuming all is ok, then we can carry on with the printing.
    //  Check for page length being zero, since this is an irrelevant
    //  value when it comes to calculating page layout.

    TEST  pagelength = 0  THEN
    $(
        //  Special case this.  Titling is meaningless, as is multicolumning.

        linespercolumn  :=  maxpagelength
        mincolumns      :=  1
        maxcolumns      :=  1
        titling         :=  FALSE
    $)
    ELSE

        //  Default case.  Just set the number of lines in a column equal to
        //  the page length.

        linespercolumn  :=  titling  ->  (pagelength - titledepth), pagelength

    //  Now do the printing.  Reset the flags for the beginning of file,
    //  and then start printing the pages.  We return when all is finished.

    endoffile   :=  FALSE
    linenumber  :=  0

    printpages()

    //  If we hit premature end of file, then it is possible that there are
    //  buffered lines waiting to be freed.

    UNTIL  linequeue = NIL  DO  freeline( dequeueline() )
$)



AND readprinters( file, list )  =  VALOF
$(
//  Read the printer definitions from the file specified, and return a pointer
//  to the list containing the information.

    LET line   =  1
    LET oldin  =  input()
    LET newin  =  findinput( file )

    IF  newin = 0  THEN  RESULTIS  list

    selectinput( newin )

    $(  //  Parse each line of the file as it comes, looking for lines which
        //  begin with "*", since these are comment lines.

        LET ch  =  rdch()

        WHILE  ch = '*S'  DO  ch  :=  rdch()

        IF  ch = '**'  THEN
            UNTIL  ch = '*N'  |  ch = endstreamch  DO
                ch  :=  rdch()

        IF  ch = endstreamch  THEN  BREAK

        UNLESS  ch = '*N'  DO
        $(
            //  A non blank line, so we should attempt to parse the line
            //  given the default argument string.

            MANIFEST
            $(
                a.name          =  0
                a.printer       =  1
                a.options       =  2
            $)

            LET args    =  "NAME/A,PRINTER/A,OPTIONS/A"
            LET argv    =  VEC 100

            unrdch()

            TEST  string.rdargs( args, argv, 100 )  THEN
            $(
                //  We have parsed the item properly, so obtain a new node for
                //  it, and add it to the data structure.

                LET node  =  getvector( p.size )

                node!p.link        :=  list
                node!p.name        :=  copystring( argv!a.name )
                node!p.printer     :=  copystring( argv!a.printer )
                node!p.options     :=  copystring( argv!a.options )

                list               :=  node
            $)
            ELSE

                //  Some sort of error here, but we can do no more than
                //  print out the line number.

                errormessage( "Syntax error in line %N of *"%S*"", line, file )
        $)

        line  :=  line + 1
    $)
    REPEAT

    endread()

    selectinput( oldin )

    RESULTIS  list
$)



AND string.rdargs( args, argv, argl )  =  VALOF
$(
//  Perform a "rdargs" by reading things into a buffer first.

    LET buffer  =  VEC 256/bytesperword
    LET length  =  0
    LET ok      =  0
    LET ch      =  rdch()

    UNTIL  ch = '*N'  |  ch = endstreamch  DO
    $(
        length           :=  length + 1
        buffer % length  :=  ch
        ch               :=  rdch()
    $)

    buffer % 0  :=  length

    //  How we handle the string we have just read in depends on the
    //  operating system.  Everything other than Panos has RDARGS
    //  reading from the current input stream.  Panos just has to
    //  be different ...

$<PANOS
    argument.string  :=  buffer
$>PANOS

$<PANOS'
    stringinput( buffer )
$>PANOS'

    ok  :=  rdargs( args, argv, argl )

$<PANOS'
    endstringinput()
$>PANOS'

    RESULTIS  ok
$)



AND lookupprinter( name )  =  VALOF
$(
//  Scan the list of printers to find an entry for the given name.

    LET list  =  printers

    UNTIL  list = NIL  DO
    $(
        IF  compstring( name, list!p.name ) = 0  THEN  RESULTIS  list

        list  :=  list!p.link
    $)

    RESULTIS  NIL
$)



AND scanforprinter( list, options )  =  VALOF
$(
//  Count the number of options in the list which actually refer to printers,
//  and return a boolean saying whether one was found.  We assume here that
//  the options string is usable as an argument to "findargument".

    LET count  =  0

    UNTIL  list = NIL  DO
    $(
        UNLESS  findargument( options, list!p.name ) = -1  DO
            count  :=  count + 1

        list  :=  list!p.link
    $)

    IF  count > 1  THEN  errormessage( "More than one printer selected" )

    RESULTIS  count > 0
$)



AND setprinter( printer )  BE
$(
//  Set the defaults for the printer given.

    decodeoptions( printer!p.options, FALSE )

    printertype  :=  printer
$)



AND decodeoptions( options, printeropt )  BE
$(
//  Read the options from the string given.  First, construct a
//  dummy input stream from the string.

    stringinput( options )

    $(  //  Repeat loop to read characters from the input stream, and
        //  check them against valid options.

        LET oplist  =  "C,MC,S,SPREAD,NOSPREAD,TITLE,NOTITLE,U,NOU,*
                       *L,W,LN,NOLN,LO,PN,NOPN,PW,NOPW,PM,CM,N,NN,*
                       *TR,NOTR,PF,INDEX,NOINDEX,POSTSCRIPT,PROLOG,DEBUG"

        LET string  =  readstring()
        LET arg     =  0

        IF  string = NIL  THEN  BREAK

        arg  :=  findargument( oplist, string )

        SWITCHON  arg  INTO
        $(
            CASE  0 :  //  C[=]n     Set number of columns to "n"

                       set.columns()
                       ENDCASE


            CASE  1 :  //  MC[=]n    Set maximum number of columns to "n"

                       set.maxcolumns()
                       ENDCASE


            CASE  2 :  //  S[=]n     Set column separation to "n"

                       set.separation()
                       ENDCASE


            CASE  3 :  //  SPREAD    Set column spreading on

                       set.spreading()
                       ENDCASE


            CASE  4 :  //  NOSPREAD  Set column spreading off

                       set.nospreading()
                       ENDCASE


            CASE  5 :  //  TITLE[=]s Set title string to "s"

                       set.title()
                       ENDCASE


            CASE  6 :  //  NOTITLE   Do not print title

                       set.notitle()
                       ENDCASE


            CASE  7 :  //  U         Underline the title

                       set.underline()
                       ENDCASE


            CASE  8 :  //  NOU       Do not underline the title

                       set.nounderline()
                       ENDCASE


            CASE  9 :  //  L[=]n     Set Page Length to "n"

                       set.pagelength()
                       ENDCASE


            CASE 10 :  //  W[=]n     Set Page Width to "n"

                       set.pagewidth()
                       ENDCASE


            CASE 11 :  //  LN        Print line numbers

                       set.numbering()
                       ENDCASE


            CASE 12 :  //  NOLN      Do not print line numbers

                       set.nonumbering()
                       ENDCASE


            CASE 13 :  //  LO[=]n    Set line offset to "n"

                       set.lineoffset()
                       ENDCASE


            CASE 14 :  //  PN        Print page numbers

                       set.paging()
                       ENDCASE


            CASE 15 :  //  NOPN      Do not print page numbers

                       set.nopaging()
                       ENDCASE


            CASE 16 :  //  PW=s      Set page waiting string to "s"

                       set.pagewait()
                       ENDCASE


            CASE 17 :  //  NOPW      Don't page wait

                       set.nopagewait()
                       ENDCASE


            CASE 18 :  //  PM        New page per output member

                       set.pagepermember()
                       ENDCASE


            CASE 19 :  //  CM        New column per output member

                       set.columnpermember()
                       ENDCASE


            CASE 20 :  //  N         Name individual files

                       set.naming()
                       ENDCASE


            CASE 21 :  //  NN        Do not name individual files

                       set.nonaming()
                       ENDCASE


            CASE 22 :  //  TR        Truncate overlong lines

                       set.truncating()
                       ENDCASE


            CASE 23 :  //  NOTR      Wrap overlong lines

                       set.notruncating()
                       ENDCASE


            CASE 24 :  //  PF[=]n    Set page factor to "n"

                       set.pagefactor()
                       ENDCASE


            CASE 25 :  //  INDEX     Print index of files

                       set.index()
                       ENDCASE


            CASE 26 :  //  NOINDEX   Do not print index of files

                       set.noindex()
                       ENDCASE


            CASE 27 :  //  POSTSCRIPT

                       set.postscript()
                       ENDCASE


            CASE 28 :  //  PROLOG[=]f  Send prolog file "f"

                       set.prolog()
                       ENDCASE


            CASE 29 :  //  DEBUG     Print debugging information

                       set.debugging()
                       ENDCASE


            CASE -1 :  //  Unknown command, but this could be the name of a
                       //  printer.  Look the printer up, and set if it
                       //  exists.

                       TEST  printeropt  THEN
                       $(
                           //  We are allowed printer names, so look up the
                           //  name in the printer file.

                           LET printer  =  lookupprinter( string )

                           TEST  printer \= NIL  THEN

                               //  This is a real printer, which will itself
                               //  have some options associated with it.

                               set.printer( printer )

                           ELSE
                           $(
                               errormessage( "Unknown option: *"%S*"  -  ignored", string )

                               skipoption()
                           $)
                       $)
                       ELSE
                       $(
                           errormessage( "Unexpected option: *"%S*"  -  ignored", string )
                           skipoption()
                       $)
                       ENDCASE


            DEFAULT :  //  Internal cock up.

                       errormessage( "Internal cock up, command *"%S*"", string )
                       skipoption()
                       ENDCASE
        $)

        freevector( string )
    $)
    REPEAT

    endstringinput()
$)



AND findargument( key, tag )  =  VALOF
$(
//  Return the sequence number of the tag "tag" in the list of keys pointed
//  to by "key".  Keys are separated by "," characters, and duplicate keys are
//  separated by "=" characters.

    LET buffer    =  VEC 256/bytesperword
    LET keyl      =  key % 0
    LET sequence  =  0
    LET length    =  0
    LET pos       =  0
    LET ch        =  0

    UNTIL  pos = keyl  DO
    $(
        //  Look at the next character in the key string to see if it is
        //  an "=" sign.  If so, then perform a comparison.

        pos  :=  pos + 1
        ch   :=  key % pos

        IF  ch = ','  |  ch = '='  THEN
        $(
            //  Compare the string we have split off with the tag given, and
            //  return TRUE if there is a match.

            buffer % 0  :=  length

            IF  compstring( buffer, tag ) = 0  THEN  RESULTIS  sequence

            //  Otherwise, reset the length of the string, and carry on to
            //  see if we can find another match.

            length  :=  0

            IF  ch = ','  THEN  sequence  :=  sequence + 1

            LOOP
        $)

        //  If this is an ordinary character, then simply put it in the
        //  buffer, and go round for more.

        length           :=  length + 1
        buffer % length  :=  ch
    $)

    //  When we drop out of the loop, we should compare with the last
    //  item in the list.

    buffer % 0  :=  length

    RESULTIS  (compstring( buffer, tag ) = 0)  ->  sequence,  -1
$)



AND readstring()  =  VALOF
$(
    LET v       =  getvector( 255 / bytesperword )
    LET ch      =  uppercase( rdch() )
    LET length  =  0

    WHILE  isterminator( ch )  DO
    $(
        IF  ch = endstreamch  THEN
        $(
            freevector( v )

            RESULTIS  NIL
        $)

        ch  :=  rdch()
    $)

    WHILE  'A' <= ch <= 'Z'  DO
    $(
        length      :=  length + 1
        v % length  :=  ch
        ch          :=  uppercase( rdch() )
    $)

    unrdch()

    v % 0  :=  length

    RESULTIS  v
$)



AND uppercase( ch )  =  'a' <= ch <= 'z'  ->  ch - 'a' + 'A',  ch



AND readnumber()  =  VALOF
$(
    LET ch      =  rdch()
    LET result  =  0

    WHILE  ch = '*S'  DO    ch  :=  rdch()
    IF     ch = '='   THEN  ch  :=  rdch()
    WHILE  ch = '*S'  DO    ch  :=  rdch()

    WHILE  '0' <= ch <= '9'  DO
    $(
        result  :=  result * 10  +  ch  -  '0'
        ch      :=  rdch()
    $)

    RESULTIS  isterminator( ch )  ->  result,  -1
$)



AND isterminator( ch )  =  (ch = ','  |  ch = endstreamch)



AND set.columns()  BE
$(
    LET number  =  readnumber()

    TEST  number = -1  THEN
        errormessage( "Invalid number after *"C*" option" )

    ELSE
    $(
        mincolumns  :=  number
        maxcolumns  :=  number
    $)
$)



AND set.maxcolumns()  BE
$(
    LET number  =  readnumber()

    TEST  number = -1  THEN  errormessage( "Invalid number after *"MC*" option" )
    ELSE
    $(
        mincolumns  :=  1
        maxcolumns  :=  number
    $)
$)



AND set.separation()  BE
$(
    LET number  =  readnumber()

    TEST  number = -1
        THEN  errormessage( "Invalid number after *"S*" option" )
        ELSE  separation  :=  number
$)



AND set.spreading()  BE
    IF  checknoargs( "SPREAD" )  THEN
        spreading  :=  TRUE



AND set.nospreading()  BE
    IF  checknoargs( "NOSPREAD" )  THEN
        spreading  :=  FALSE



AND set.index()  BE
    IF  checknoargs( "INDEX" )  THEN
    $(
        indexing  :=  TRUE
        paging    :=  TRUE
        titling   :=  TRUE
    $)



AND set.noindex()  BE
    IF  checknoargs( "NOINDEX" )  THEN
        indexing  :=  FALSE



AND set.title()  BE
$(
    LET titlevec  =  getvector( 255/bytesperword )
    LET quoted    =  FALSE
    LET length    =  0
    LET ch        =  rdch()

    WHILE  ch = '*S'  DO    ch  :=  rdch()
    IF     ch = '='   THEN  ch  :=  rdch()
    WHILE  ch = '*S'  DO    ch  :=  rdch()

    IF  ch = '*''  THEN
    $(
        quoted  :=  TRUE
        ch      :=  rdch()
    $)

    $(  //  Loop to read the title string from the input stream.  Continue
        //  reading until the terminator is found (either a real terminator
        //  or a quote.

        IF  ch = endstreamch  THEN  BREAK

        TEST  quoted  THEN
            IF  ch = '*''  THEN
            $(
                ch  := rdch()

                UNLESS  ch = '*''  DO
                $(
                    unrdch()
                    BREAK
                $)
            $)

        ELSE
            IF  isterminator( ch )  THEN  BREAK

        length             :=  length + 1
        titlevec % length  :=  ch
        ch                 :=  rdch()
    $)
    REPEAT

    titlevec % 0  :=  length

    UNLESS  title = NIL  DO  freevector( title )

    TEST  length = 0  THEN
    $(
        freevector( titlevec )

        title  :=  NIL
    $)
    ELSE  title  :=  titlevec

    titling  :=  TRUE
$)



AND set.notitle()  BE
    IF  checknoargs( "NOTITLE" )  THEN
        titling  :=  FALSE



AND set.underline()  BE
    IF  checknoargs( "U" )  THEN
    $(
        underlining  :=  TRUE
        titling      :=  TRUE
    $)



AND set.nounderline()  BE
    IF  checknoargs( "NOU" )  THEN
        underlining  :=  FALSE


AND set.pagelength()  BE
$(
    LET number  =  readnumber()

    TEST  number = -1
        THEN  errormessage( "Invalid number after *"P*" option" )
        ELSE  pagelength  :=  number
$)



AND set.pagewidth()  BE
$(
    LET number  =  readnumber()

    TEST  number = -1
        THEN  errormessage( "Invalid number after *"W*" option" )
        ELSE  linelength  :=  number
$)



AND set.numbering()  BE
    IF  checknoargs( "LN" )  THEN
    $(
        numbering  :=  TRUE
        titling    :=  TRUE
    $)



AND set.nonumbering()  BE
    IF  checknoargs( "NOLN" )  THEN
        numbering  :=  FALSE



AND set.lineoffset()  BE
$(
    LET number  =  readnumber()

    TEST  number = -1
        THEN  errormessage( "Invalid number after *"LO*" option" )
        ELSE  lineoffset  :=  number
$)



AND set.paging()  BE
    IF  checknoargs( "PN" )  THEN
    $(
        paging   :=  TRUE
        titling  :=  TRUE
    $)



AND set.nopaging()  BE
    IF  checknoargs( "NOPN" )  THEN
        paging  :=  FALSE



AND set.pagewait()  BE
$(
    LET waitvec   =  getvector( 255/bytesperword )
    LET quoted    =  FALSE
    LET length    =  0
    LET ch        =  rdch()

    WHILE  ch = '*S'  DO    ch  :=  rdch()
    IF     ch = '='   THEN  ch  :=  rdch()
    WHILE  ch = '*S'  DO    ch  :=  rdch()

    IF  ch = '*''  THEN
    $(
        quoted  :=  TRUE
        ch      :=  rdch()
    $)

    $(  //  Loop to read the wait string from the input stream.  Continue
        //  reading until the terminator is found (either a real terminator
        //  or a quote.

        IF  ch = endstreamch  THEN  BREAK

        TEST  quoted  THEN
            IF  ch = '*''  THEN
            $(
                ch  := rdch()

                UNLESS  ch = '*''  DO
                $(
                    unrdch()
                    BREAK
                $)
            $)

        ELSE
            IF  isterminator( ch )  THEN  BREAK

        length            :=  length + 1
        waitvec % length  :=  ch
        ch                :=  rdch()
    $)
    REPEAT

    waitvec % 0  :=  length

    UNLESS  waitstring = NIL  DO  freevector( waitstring )

    TEST  length = 0  THEN
    $(
        freevector( waitvec )

        waitstring  :=  copystring( page.waiting )
    $)
    ELSE  waitstring  :=  waitvec
$)



AND set.nopagewait()  BE
    IF  checknoargs( "NOPW" )  THEN
    $(
        UNLESS  waitstring = NIL  DO  freevector( waitstring )

        waitstring  :=  NIL
    $)



AND set.pagepermember()  BE
    IF  checknoargs( "PM" )  THEN
        pagepermember  :=  TRUE



AND set.columnpermember()  BE
    IF  checknoargs( "CM" )  THEN
        columnpermember  :=  TRUE



AND set.naming()  BE
    IF  checknoargs( "N" )  THEN
    $(
        naming     :=  TRUE
        namingset  :=  TRUE
    $)



AND set.nonaming()  BE
    IF  checknoargs( "NN" )  THEN
    $(
        naming     :=  FALSE
        namingset  :=  TRUE
    $)



AND set.truncating()  BE
    IF  checknoargs( "TR" )  THEN
        truncating  :=  TRUE



AND set.notruncating()  BE
    IF  checknoargs( "NOTR" )  THEN
        truncating  :=  FALSE



AND set.pagefactor()  BE
$(
    LET number  =  readnumber()

    TEST  number = -1
        THEN  errormessage( "Invalid number after *"PF*" option" )
        ELSE  pagefactor  :=  number
$)



AND set.prolog()  BE
$(
    LET prologvec  =  getvector( 255/bytesperword )
    LET quoted     =  FALSE
    LET length     =  0
    LET ch         =  rdch()

    WHILE  ch = '*S'  DO    ch  :=  rdch()
    IF     ch = '='   THEN  ch  :=  rdch()
    WHILE  ch = '*S'  DO    ch  :=  rdch()

    IF  ch = '*''  THEN
    $(
        quoted  :=  TRUE
        ch      :=  rdch()
    $)

    $(  //  Loop to read the prolog string from the input stream.  Continue
        //  reading until the terminator is found (either a real terminator
        //  or a quote.

        IF  ch = endstreamch  THEN  BREAK

        TEST  quoted  THEN
            IF  ch = '*''  THEN
            $(
                ch  := rdch()

                UNLESS  ch = '*''  DO
                $(
                    unrdch()
                    BREAK
                $)
            $)

        ELSE
            IF  isterminator( ch )  THEN  BREAK

        length              :=  length + 1
        prologvec % length  :=  ch
        ch                  :=  rdch()
    $)
    REPEAT

    prologvec % 0  :=  length

    UNLESS  prolog = NIL  DO  freevector( prolog )

    TEST  length = 0  THEN
    $(
        freevector( prologvec )

        prolog  :=  NIL
    $)
    ELSE  prolog  :=  prologvec
$)



AND set.printer( printer )  BE
$(
//  Set up the required printer.  The optional argument is the name of the
//  output to be printed.

    LET titlevec  =  getvector( 255/bytesperword )
    LET quoted    =  FALSE
    LET length    =  0
    LET ch        =  rdch()

    LET buff      =  0
    LET buffb     =  0

    WHILE  ch = '*S'  DO    ch  :=  rdch()
    IF     ch = '='   THEN  ch  :=  rdch()
    WHILE  ch = '*S'  DO    ch  :=  rdch()

    IF  ch = '*''  THEN
    $(
        quoted  :=  TRUE
        ch      :=  rdch()
    $)

    $(  //  Loop to read the title string from the input stream.  Continue
        //  reading until the terminator is found (either a real terminator
        //  or a quote.

        IF  ch = endstreamch  THEN  BREAK

        TEST  quoted  THEN
            IF  ch = '*''  THEN
            $(
                ch  := rdch()

                UNLESS  ch = '*''  DO
                $(
                    unrdch()
                    BREAK
                $)
            $)

        ELSE
            IF  isterminator( ch )  THEN  BREAK

        length             :=  length + 1
        titlevec % length  :=  ch
        ch                 :=  rdch()
    $)
    REPEAT

    titlevec % 0  :=  length

    TEST  length = 0  THEN  freevector( titlevec )
    ELSE
    $(
        UNLESS  opentitle = NIL  DO  freevector( opentitle )

        opentitle  :=  titlevec
    $)

    //  The open title is now set up properly.  We can now set up the shape
    //  of the printer.  Since the printer has an option string associated
    //  with it, we should preserve our own, so that we can go back to it.

    buff   :=  copystring( stringbuff )
    buffb  :=  stringbuffb

    endstringinput()

    setprinter( printer )

    stringinput( buff )
    freevector( buff )

    stringbuffb  :=  buffb
$)



AND set.debugging()  BE
    IF  checknoargs( "DEBUG" )  THEN
        debugging  :=  TRUE



AND set.postscript()  BE
    IF  checknoargs( "POSTSCRIPT" )  THEN
        postscript  :=  TRUE



AND checknoargs( option )  =  VALOF
$(
    LET ch  =  rdch()

    TEST  isterminator( ch )  THEN  RESULTIS  TRUE
    ELSE
    $(
        errormessage( "Invalid character *"%C*" after *"%S*" option",
                       ch, option )

        skipoption()

        RESULTIS  FALSE
    $)
$)



AND skipoption()  BE
$(
    LET ch  =  rdch()

    UNTIL  isterminator( ch )  DO  ch  :=  rdch()
$)



AND printpages()  BE
$(
//  We have a completely fresh piece of paper on which to work.  We must
//  take the file line by line, and add it the the virtual page, doing
//  multi-columning if necessary.

    LET pagewidth   =  linelength - lineoffset
    LET pagevec     =  getpagevec()
    LET offset      =  lineoffset
    LET fixedwidth  =  mincolumns = maxcolumns
    LET spacing     =  fixedwidth  &  (maxcolumns > 1)

    LET pagefull    =  FALSE
    LET lasttime    =  FALSE
    LET finished    =  FALSE

    //  Since we might be printing multiple files on this page, we had
    //  better make sure that the page title matches up to the file
    //  at the top of the page.

    pagename  :=  copystring( filename )

    FOR  column = 1  TO  maxcolumns  DO
    $(
        //  For each potential column on the page, we must get lines from
        //  the file to fill it.  If we are using a fixed number of columns,
        //  or this is the first column, then we must ALWAYS line wrap.
        //  Otherwise, we must move onto another page.

        TEST  column = 1  |  fixedwidth  THEN
        $(
            //  We are printing the file in a fixed width column format.  First,
            //  calculate the column width we are going to use.

            LET margin       =  spacing  ->  separation, 0
            LET columnwidth  =  pagewidth / mincolumns  -  margin
            LET columnvec    =  getcolumnvec()
            LET npcount      =  0

        startagain:

            FOR  i = 1  TO  linespercolumn  DO
            $(
                LET line  =  getline( column, columnwidth, offset, TRUE )

                IF  endoffile  THEN
                $(
                    //  What we do here depends on the options given to us.
                    //  If we have the "CM" option, then we should go to the
                    //  to of a new column.  If we have the "PM" option, we
                    //  should go to the top of a new page.

                    UNLESS  standardinput  DO  endread()

                    freevector( filename )

                    endoffile  :=  FALSE

                    //  If we have been aborted, then now is the time for
                    //  us to call a halt to the proceedings.

                    IF  aborted  THEN  BREAK

                    //  Otherwise, we can go on to the next file (if there
                    //  is one of course)

                    TEST  scbqueue = NIL  THEN
                    $(
                        //  No more pages to print, so finish off.  We print
                        //  this page, and then finish the operation.

                        finished  :=  TRUE

                        BREAK
                    $)
                    ELSE
                    $(
                        //  There is another file to print, and so we should
                        //  decide where we are going to print it.

                        LET link  =  scbqueue!fl.link
                        LET name  =  scbqueue!fl.name

                        freevector( scbqueue )

                        selectinput( getscb( scbqueue ) )

                        filename    :=  name
                        scbqueue    :=  link
                        linenumber  :=  0

                        IF  naming  THEN  generatename( filename )

                        IF  pagepermember  THEN
                        $(
                            pagefull  :=  TRUE

                            addindex( filename, pagenumber + 1 )

                            BREAK
                        $)

                        addindex( filename, pagenumber )

                        IF  columnpermember  |  i > linespercolumn - (naming -> 8, 6)  THEN

                            //  We want to start a new column, which just
                            //  involves leaving this column.

                            BREAK

                        //  Otherwise, we queue up blank lines, and
                        //  go round again.

                        enqueueline( NIL )
                        enqueueline( NIL )
                    $)
                $)

                IF  line = NIL  THEN

                    //  This is a null line.  It is possible that this is
                    //  the only line on the page, in which case we should
                    //  stop now.

                    IF  column = 1  &  i = 1  THEN
                    $(
                        freevector( columnvec )
                        freevector( pagevec )

                        RETURN
                    $)


                IF  line = print.newpage  THEN

                    //  We have found a "*P" character.  Ignore it if we are
                    //  already at the top of a new page.

                    TEST  i = 1  THEN  GOTO startagain
                    ELSE
                    $(
                        npcount  :=  npcount + 1

                        TEST  npcount = pagefactor  THEN  BREAK
                        ELSE
                        $(
                            //  We should leave blank lines here.  If we are
                            //  not spreading, then leave "separation" blank
                            //  lines, otherwise move to the logical page
                            //  position.

                            LET lines  =  linespercolumn/pagefactor
                            LET next1  =  i + separation - 1
                            LET next2  =  roundup( next1, lines )

                            LET next   =  spreading  ->  next2, next1

                            //  Having calculated where the next page would
                            //  start, look to see that there is enough room
                            //  left in the page.

                            IF  (linespercolumn - next) < 4  THEN  BREAK

                            //  There is enough room, so put out enough blank
                            //  lines to pad us to the correct position.

                            FOR  j = 1  TO  next-i-1  DO  enqueueline( NIL )

                            line  :=  NIL
                        $)
                    $)

                columnvec!i  :=  line
            $)

            pagevec!column  :=  columnvec

            TEST  fixedwidth  THEN

                //  This is a fixed width column, and so the calculation of the
                //  next offset is easy, since all lines are effectively the
                //  same length.

                offset  :=  offset + columnwidth + separation

            ELSE

                //  This is slightly more complicated.  This is the first
                //  column of multi columned output, and hence we want to
                //  calculate what the longest line is, and set the offset
                //  to that.

                offset  :=  offset + longestline( columnvec ) + separation
        $)
        ELSE
        $(
            //  This is a column other that one, and we are potentially
            //  multi-columning.  We should therefore calculate the amount
            //  of space left on the current page.

            LET columnwidth  =  linelength - offset
            LET columnvec    =  getcolumnvec()
            LET npcount      =  0

        startagain:

            FOR  i = 1  TO  linespercolumn  DO
            $(
                LET line  =  getline( column, columnwidth, offset, FALSE )

                IF  endoffile  THEN
                $(
                    //  What we do here depends on the options given to us.
                    //  If we have the "CM" option, then we should go to the
                    //  to of a new column.  If we have the "PM" option, we
                    //  should go to the top of a new page.

                    UNLESS  standardinput  DO  endread()

                    freevector( filename )

                    endoffile  :=  FALSE

                    //  If we have been aborted, then now is the time for
                    //  us to call a halt to the proceedings.

                    IF  aborted  THEN  BREAK

                    //  Otherwise, we can go on to the next file (if there
                    //  is one of course)

                    TEST  scbqueue = NIL  THEN
                    $(
                        //  No more pages to print, so finish off.  We print
                        //  this page, and then finish the operation.

                        finished  :=  TRUE

                        BREAK
                    $)
                    ELSE
                    $(
                        //  There is another file to print, and so we should
                        //  decide where we are going to print it.

                        LET link  =  scbqueue!fl.link
                        LET name  =  scbqueue!fl.name

                        freevector( scbqueue )

                        selectinput( getscb( scbqueue ) )

                        filename    :=  name
                        scbqueue    :=  link
                        linenumber  :=  0

                        IF  naming  THEN  generatename( filename )

                        IF  pagepermember  THEN
                        $(
                            pagefull  :=  TRUE

                            addindex( filename, pagenumber + 1 )

                            BREAK
                        $)

                        addindex( filename, pagenumber )

                        IF  columnpermember  |  i > linespercolumn - (naming -> 8, 6)  THEN

                            //  We want to start a new column, which just
                            //  involves leaving this column.

                            BREAK

                        //  Otherwise, we queue up blank lines, and
                        //  go round again.

                        enqueueline( NIL )
                        enqueueline( NIL )
                    $)
                $)

                //  If the result from that call were "print.toolong" then
                //  we have been unable to fit this line into the column
                //  provided, and hence we should discard it.

                IF  line = print.toolong  THEN
                $(
                    FOR  j = i-1  TO  1  BY  -1  DO  enqueueline( columnvec!j )

                    freevector( columnvec )

                    columnvec  :=  NIL
                    pagefull   :=  TRUE

                    BREAK
                $)

                IF  line = print.newpage  THEN

                    //  We have found a "*P" character.  Ignore it if we are
                    //  already at the top of a new page.

                    TEST  i = 1  THEN  GOTO startagain
                    ELSE
                    $(
                        npcount  :=  npcount + 1

                        TEST  npcount = pagefactor  THEN  BREAK
                        ELSE
                        $(
                            //  We should leave blank lines here.  If we are
                            //  not spreading, then leave "separation" blank
                            //  lines, otherwise move to the logical page
                            //  position.

                            LET lines  =  linespercolumn/pagefactor
                            LET next1  =  i + separation - 1
                            LET next2  =  roundup( next1, lines )

                            LET next   =  spreading  ->  next2, next1

                            //  Having calculated where the next page would
                            //  start, look to see that there is enough room
                            //  left in the page.

                            IF  (linespercolumn - next) < 4  THEN  BREAK

                            //  There is enough room, so put out enough blank
                            //  lines to pad us to the correct position.

                            FOR  j = 1  TO  next-i-1  DO  enqueueline( NIL )

                            line  :=  NIL
                        $)
                    $)

                columnvec!i  :=  line
            $)

            pagevec!column  :=  columnvec
            offset          :=  offset + longestline( columnvec ) + separation
        $)

        IF  pagefull  |  finished  |  aborted  |  toosmall( linelength - offset )  THEN  BREAK
    $)

    //  When we drop out of that lot, the page is full, and we should
    //  submit it to the output routine to be sent off.

    IF  spreading  &  NOT fixedwidth  THEN
    $(
        //  At this point, we can spread the lines if we have been
        //  requested to do so.

        LET spacesleft  =  linelength - offset

        IF  spacesleft > 0  THEN  spreadlines( pagevec, spacesleft )
    $)

    //  Check the aborted flag, and if set, print out a page for the
    //  last time.

    lasttime  :=  aborted  |  finished

    outputpage( pagevec )
    freevector( pagename )

    //  This is our last chance to print something, so we had better look
    //  to see if we have to produce an index.  If so, then we should
    //  do that now.

    IF  finished  &  indexing  &  NOT aborted  THEN  printindex()

    //  If this is the last time, then goodbye cruel world...

    IF  lasttime  THEN  RETURN
$)
REPEAT



AND printindex()  BE
$(
//  Print the index at the end of a print run.  We should enqueue the index
//  lines in reverse order, so that they come out in the right order on the
//  page.  The "line number" mechanism is used to print the page numbers.

    LET finished  =  FALSE
    LET count     =  1

    UNTIL  indexlist = NIL  DO
    $(
        LET link    =  indexlist!ie.link
        LET page    =  indexlist!ie.pagenumber
        LET name    =  indexlist!ie.filename

        LET length  =  name % 0

        LET line    =  getlineentry( length )
        LET buff    =  line + le.chars

        line!le.link        :=  NIL
        line!le.overprint   :=  NIL
        line!le.linenumber  :=  page
        line!le.offset      :=  0

        FOR  i = 0  TO  length  DO  buff % i  :=  name % i

        enqueueline( line )

        freevector( name )
        freevector( indexlist )

        indexlist  :=  link
    $)

    //  Having enqueued the files, we can now read them back again, forming
    //  them into pages.  We set the "end of file" flag, to stop any further
    //  reading of a disc file.  End of file is marked by "NIL".

    endoffile  :=  TRUE

    UNTIL  finished  DO
    $(
        LET pagevec    =  getpagevec()
        LET columnvec  =  getcolumnvec()

        FOR  i = 1  TO  linespercolumn  DO
        $(
            LET line  =  getline( 1, linelength-lineoffset, lineoffset, TRUE )

            IF  line = NIL  THEN
            $(
                finished  :=  TRUE

                BREAK
            $)

            columnvec!i  :=  line
        $)

        pagevec!1  :=  columnvec
        pagename   :=  copystring( count = 1 -> "Index", "Index (continued)" )

        outputpage( pagevec )
        freevector( pagename )

        count      :=  count + 1
    $)
$)



AND addindex( name, page )  BE
$(
//  Add an entry to the index table for the file name and page number given.

    LET entry  =  getvector( ie.size )

    entry!ie.link        :=  indexlist
    entry!ie.pagenumber  :=  page + 1
    entry!ie.filename    :=  copystring( name )

    IF  debugging  THEN
        message( "Page %N, starting file *"%S*"", page+1, name )

    indexlist            :=  entry
$)



AND generatename( name )  BE
$(
//  Enqueue a name line onto the line queue, so that files will come out
//  each preceeded by their name.

    LET length  =  name % 0
    LET line    =  getlineentry( length )
    LET buff    =  line + le.chars

    line!le.link        :=  NIL
    line!le.overprint   :=  NIL
    line!le.linenumber  :=  0
    line!le.offset      :=  0

    FOR  i = 0  TO  length  DO  buff % i  :=  name % i

    enqueueline( NIL )
    enqueueline( line )
$)



AND spreadlines( pagevec, spacesleft )  BE
$(
//  Spread the free space left around the columns.  The value of "columns" is
//  the number of columns successfully put onto the page.

    LET columns          =  countcolumns( pagevec )
    LET pagewidth        =  linelength - lineoffset
    LET columnwidth      =  0
    LET spreadoffset     =  0

    IF  columns < 2  THEN  RETURN    //  Spreads straight from the fridge!

    columnwidth  :=  pagewidth / columns

    IF  debugging  THEN
        message( "Page %N  (%N columns, %N chars/column)",
                  pagenumber+1, columns, columnwidth )

    FOR  i = 2  TO  columns  DO
    $(
        LET ideal      =  columnwidth * (i-1)
        LET columnvec  =  pagevec!i
        LET offset     =  findoffset( columnvec ) - lineoffset + spreadoffset

        IF  offset < ideal  THEN
        $(
            //  We should move this column right to its ideal position, if
            //  there are enough spaces left.

            LET newoffset  =  min( ideal, offset + spacesleft )
            LET indent     =  newoffset - offset

            IF  debugging  THEN
            $(
                //  Print out some information about this page, and the
                //  position of the columns on it.

                message( "Page %N, Column %N, Ideal offset %N",
                          pagenumber+1, i, ideal+lineoffset )

                message( "Current offset %N, New offset %N, (%N spaces)",
                          offset+lineoffset, newoffset+lineoffset, spacesleft )
            $)

            offset        :=  newoffset

            spacesleft    :=  spacesleft   - indent
            spreadoffset  :=  spreadoffset + indent
        $)

        offset  :=  offset + lineoffset

        FOR  j = 1  TO  linespercolumn  DO
        $(
            LET line  =  columnvec!j

            UNTIL  line = NIL  DO
            $(
                line!le.offset  :=  offset
                line            :=  line!le.overprint
            $)
        $)
    $)
$)



AND countcolumns( pagevec )  =  VALOF
$(
    LET count  =  0

    FOR  i = 1  TO  maxcolumns  DO
        UNLESS  pagevec!i = NIL  DO
            count  :=  count + 1

    RESULTIS  count
$)



AND toosmall( columnwidth )  =  columnwidth < mincolumnwidth



AND roundup( value, amount )  =  VALOF
$(
//  Round the number "value" to the next multiple of "amount".

    LET firsttry   =  value + amount - 1
    LET overshoot  =  firsttry REM amount

    RESULTIS  firsttry - overshoot
$)



AND min( a, b )  =  a < b  ->  a, b



AND findoffset( column )  =  column = NIL  ->  0,  VALOF
$(
//  Find the first line in this column which has an "offset" value.

    FOR  i = 1  TO  linespercolumn  DO
    $(
        LET line  =  column!i

        UNLESS  line = NIL  DO  RESULTIS  line!le.offset
    $)

    RESULTIS  0
$)



AND outputpage( pagevec, pagename )  BE
$(
//  Output a page to the printer.  If we are coroutining, then we must schedule
//  the page to be printed, otherwise, print it immediately.

$<TRIPOS
    pagepointer  :=  pagevec

    UNTIL  pagepointer = NIL  DO  delay( tickspersecond/10 )
$>TRIPOS

$<TRIPOS'
    UNLESS  pagevec = print.end  DO  printoutputpage( pagevec )
$>TRIPOS'
$)



AND endinput()  BE  outputpage( print.end )



$<TRIPOS
AND printoutput()  =  VALOF
$(
//  Main output coroutine.  Wait for a page to be produced, and then print
//  it.

    WHILE  pagepointer = NIL  DO  delay( tickspersecond/10 )

    IF  pagepointer = print.end  THEN
    $(
        pagepointer  :=  NIL

        RESULTIS  NIL
    $)

    printoutputpage( pagepointer )
$)
REPEAT
$>TRIPOS



AND printoutputpage( pagevec )  BE
$(
//  Print a page whose page vector is "pagevec".  Take the page which has been
//  buffered, and print it out.  Since the information on the top of the page
//  is transient (title etc.) we cannot acknowledge receipt of the page until
//  we have finished with this information.  We acknowledge receipt by setting
//  the variable "pagepointer" to NIL.

    LET lastline  =  findlastline( pagevec )

    pagenumber  :=  pagenumber + 1

    IF  titling  &  NOT aborted  THEN
    $(
        LET titlevec     =  title = NIL  ->  pagename,  title
        LET titlelength  =  titlevec % 0    +
                            datestring % 0  +
                            timestring % 0  +  4

        FOR  i = 1  TO  lineoffset  DO  wrch( '*S' )

        IF  paging  THEN
        $(
            writef( "Page %N  ", pagenumber )

            titlelength  :=  titlelength + digits( pagenumber ) + 7
        $)

        writef( "%S  %S  %S", titlevec, datestring, timestring )

        IF  underlining  THEN
        $(
            wrch( '*C' )

            FOR  i = 1  TO  lineoffset   DO  wrch( '*S' )
            FOR  i = 1  TO  titlelength  DO  wrch( '_' )
        $)

        writes( "*N*N" )
    $)

$<TRIPOS
    //  We have now extracted all relevant information from the input side
    //  of the program, and hence we can tell it so.

    pagepointer  :=  NIL
$>TRIPOS

    FOR  i = 1  TO  lastline  DO
    $(
        //  For each line in the output we must print the buffered characters,
        //  (and any overprinted lines as well).

        LET finished   =  TRUE

        $(  //  Repeat loop to take the buffered lines in each column, and
            //  print them out.

            LET offset  =  0

            FOR  j = 1  TO  maxcolumns  DO
            $(
                LET columnvec  =  pagevec!j
                LET linevec    =  columnvec = NIL  ->  NIL,  columnvec!i

                UNLESS  linevec = NIL  DO
                $(
                    LET loffset  =  linevec!le.offset
                    LET loprint  =  linevec!le.overprint
                    LET lnumber  =  linevec!le.linenumber
                    LET chars    =  linevec + le.chars
                    LET length   =  chars % 0

                    UNLESS  aborted  DO
                    $(
                        FOR  k = offset  TO  loffset-1  DO  wrch( '*S' )

                        IF  lnumber > 0  THEN
                        $(
                            //  Line number required.

                            length  :=  length + numberwidth

                            writed( lnumber, numberwidth-2 )
                            writes( "  " )
                        $)

                        IF  lnumber < 0  THEN
                        $(
                            //  Overflow from line numbered output.

                            length  :=  length + numberwidth

                            FOR  k = 1  TO  numberwidth  DO  wrch( '*S' )
                        $)

                        writes( chars )

                        offset  :=  loffset + length
                    $)

                    //  We can now free this part of the line, and move on
                    //  to greater things.

                    freevector( linevec )

                    columnvec!i  :=  loprint

                    UNLESS  loprint = NIL  DO  finished  :=  FALSE
                $)
            $)

            //  When we drop out here, we have printed one line.  We may
            //  Have to overprint though.

            TEST  finished  THEN  BREAK
            ELSE
            $(
                UNLESS  aborted  DO  wrch( '*C' )

                finished  :=  TRUE
            $)
        $)
        REPEAT

        //  End of a line.  Terminate the line with a '*N'

        UNLESS  aborted  DO  wrch( '*N' )
    $)

    //  End of a page.  Nothing left to do, but to free "pagevec" and its
    //  associated "columnvec"s.

    FOR  i = 1  TO  maxcolumns  DO
    $(
        LET columnvec  =  pagevec!i

        UNLESS  columnvec = NIL  DO  freevector( columnvec )
    $)

    freevector( pagevec )

    //  If we are page waiting, then we must wait here.

    UNLESS  waitstring = NIL  |  standardinput  |  standardoutput  |  aborted  DO
    $(
        LET i    =  input()
        LET o    =  output()
        LET w    =  wrch
        LET qch  =  0
        LET ch   =  0

        selectinput( sysin )
        selectoutput( sysout )

        wrch  :=  syswrch

$<VAXUNIX
        newline()

        prompt( waitstring )
$>VAXUNIX

$<VAXUNIX'
        writef( "*N%S", waitstring )

        flushoutput()
$>VAXUNIX'

        wrch  :=  w

        qch   :=  uppercase( rdch() )
        ch    :=  qch

        UNTIL  ch = '*N'  |  ch = '*E'  |  ch = endstreamch  DO  ch  :=  rdch()

        IF  qch = 'Q'  |  qch = endstreamch  THEN
        $(
            endoffile  :=  TRUE
            aborted    :=  TRUE
        $)

        UNLESS  i = 0  DO  selectinput( i )
        UNLESS  o = 0  DO  selectoutput( o )
    $)

    //  We may not have filled the page up, so make sure that we move onto
    //  the next page before we continue.

    flushpage()
$)



$<TRIPOS
//  Under Tripos, we can usually have lots of files open at once, so we
//  leave them open while we are printing.

AND putscb( scb, special )  =  scb



AND getscb( list )  =  VALOF
$(
    LET scb  =  list!fl.scb

    standardinput  :=  list!fl.special

    RESULTIS  scb
$)
$>TRIPOS



$<TRIPOS'
//  Under operating systems other than Tripos, there may be a limit to the
//  number of files which can be open at once.  We therefore only open the
//  file when necessary.



AND putscb( scb, special )  =  special  ->  scb,  VALOF
$(
//  Close the scb and return NIL.

    LET i  =  input()

    selectinput( scb )
    endread()
    selectinput( i )

    RESULTIS  NIL
$)



AND getscb( list )  =  VALOF
$(
//  Open the file whose name is in the node given, and return with that file
//  open.  The list must be updated with the SCB, so that the error recovery
//  works.

    LET name  =  list!fl.name
    LET scb   =  list!fl.scb

    standardinput  :=  list!fl.special

    UNLESS  standardinput  DO
    $(
        scb  :=  findinput( name )

        IF  scb = 0  THEN
        $(
            errormessage( "(Internal)  Failed to open *"%S*"", name )
        
            abort( 9999 )
        $)

        list!fl.scb  :=  scb
    $)

    RESULTIS  scb
$)
$>TRIPOS'



AND flushpage()  BE
    UNLESS  pagelength = 0  |  printertype = d.vdu  DO
        wrch( '*P' )



AND findlastline( pagevec )  =  VALOF
$(
//  Find the last line used on the given page.

    LET lastline  =  0

    FOR  i = 1  TO  maxcolumns  DO
    $(
        LET last  =  findlast( pagevec!i )

        IF  last > lastline  THEN  lastline  :=  last
    $)

    RESULTIS  lastline
$)



AND findlast( column )  =  column = NIL  ->  0,  VALOF
$(
//  Scan the column to find the last line used.

    FOR  i = linespercolumn  TO  1  BY  -1  DO
        UNLESS  column!i = NIL  DO
            RESULTIS  i

    RESULTIS  0
$)



AND digits( number )  =  number < 10  ->  1,  (digits( number/10 ) + 1)



AND copystring( string )  =  string = NIL  ->  NIL,  VALOF
$(
    LET length  =  string % 0
    LET v       =  getvector( length / bytesperword )

    FOR  i = 0  TO  length  DO  v % i  :=  string % i

    RESULTIS  v
$)



AND longestline( columnvec )  =  columnvec = NIL  ->  0,  VALOF
$(
//  Find the length of the longest line in a column.

    LET longest  =  0

    FOR  i = 1  TO  linespercolumn  DO
    $(
        LET line  =  columnvec!i

        UNLESS  line = NIL  DO
        $(
            LET length  =  findlength( line )

            IF  length > longest  THEN  longest  :=  length
        $)
    $)

    RESULTIS  longest
$)



AND findlength( line )  =  VALOF
$(
//  Find the length of the longest overprinted item in a line.

    LET longest  =  0

    UNTIL  line = NIL  DO
    $(
        LET ln      =  line!le.linenumber
        LET chars   =  line + le.chars
        LET length  =  chars % 0

        UNLESS  ln = 0  DO  length  :=  length + numberwidth

        IF  length > longest  THEN  longest  :=  length

        line  :=  line!le.overprint
    $)

    RESULTIS  longest
$)



AND getline( column, columnwidth, offset, splitline )  =  VALOF
$(
//  Get a line from the input queue, assuming it has the right specifications.
//  If the flag "splitline" is TRUE, then we must always split the line,
//  but if not, we must only return the line if it has the correct shape.

    LET line    =  dequeueline()
    LET length  =  0

    IF  line = NIL  |  line = print.newpage  THEN  RESULTIS  line

    //  Otherwise, we have a line to play with.  We should get the length
    //  of the line, and check it, that we can reject it if necessary.

    length  :=  findlength( line )

    IF  length > columnwidth  &  NOT splitline  THEN
    $(
        //  We must reject this line, and return an error.

        enqueueline( line )

        RESULTIS  print.toolong
    $)

    //  Fair enough.  We have decided that the line is acceptable, and so
    //  we must do something about it.  This does not mean that it is short
    //  enough, and so, we must split the line if necessary.

    IF  length > columnwidth  THEN
    $(
        //  We do have to split the line.  We have to bear in mind that the
        //  line will be shorter than "length" if we are numbering lines, and
        //  so we must take account of this.

        LET deduction   =  numbering  ->  numberwidth, 0
        LET reallength  =  columnwidth - deduction
        LET nextline    =  NIL
        LET lineentry   =  line

        UNTIL  lineentry = NIL  DO
        $(
            //  Look at this element of the line, and see if it needs
            //  splitting.  If it does, just reset the length in the
            //  current line, and make a new copy of the rest of the
            //  line for a rainy day.

            LET linechars     =  lineentry + le.chars
            LET stringlength  =  linechars % 0

            IF  stringlength > reallength  THEN

                //  What we do here depends on whether we are wrapping or
                //  truncating.

                TEST  truncating  THEN  linechars % 0  :=  reallength
                ELSE
                $(
                    //  This string is too long.   Get a new entry item and
                    //  copy the rest of the string across.

                    LET lnumber  =  ABS lineentry!le.linenumber
                    LET diff     =  stringlength - reallength
                    LET entry    =  getlineentry( diff )
                    LET chars    =  entry + le.chars

                    FOR  i = 1  TO  diff  DO
                        chars % i  :=  linechars % (reallength + i)

                    linechars % 0        :=  reallength
                    chars % 0            :=  diff

                    entry!le.overprint   :=  nextline
                    entry!le.linenumber  :=  -lnumber

                    nextline             :=  entry
                $)

            //  Move on to the next line in the overprint sequence.

            lineentry  :=  lineentry!le.overprint
        $)

        //  When we drop through here, the current line has been butchered
        //  to bring it within specification, and we have a new line which
        //  is the result of the line split.  Push this line onto the input
        //  queue, so that we will get it next time.

        UNLESS  nextline = NIL  DO  enqueueline( nextline )
    $)

    //  When we drop out of that lot, we have the line in our hand which
    //  should be returned to the caller.

    RESULTIS  setoffset( line, offset )
$)



AND setoffset( line, offset )  =  VALOF
$(
    LET lineptr  =  line

    UNTIL  line = NIL  DO
    $(
        line!le.offset  :=  offset
        line            :=  line!le.overprint
    $)

    RESULTIS  lineptr
$)



AND enqueueline( line )  BE
$(
//  Push an input line back into the queue.  It is possible that we are
//  enqueueing NIL (a blank line), and if so, we must generate a real blank
//  line in its place.

    IF  line = NIL  THEN
    $(
        line  :=  getlineentry( 0 )

        line!le.link         :=  NIL
        line!le.overprint    :=  NIL
        line!le.linenumber   :=  0
        line!le.offset       :=  0

        (line+le.chars) % 0  :=  0
    $)

    line!le.link  :=  linequeue
    linequeue     :=  line
$)



AND dequeueline()  =  linequeue = NIL  ->  readline(),  VALOF
$(
    LET line  =  linequeue

    linequeue  :=  linequeue!le.link

    RESULTIS  line
$)



AND readline()  =  endoffile  ->  NIL,  VALOF
$(
    LET line  =  NIL
    LET ch    =  0

$<TRIPOS
    IF  testflags( #B0001 )  THEN
    $(
        //  Break.  Set the "end of file" and "aborted" flags.

        errormessage( "BREAK." )

        endoffile  :=  TRUE
        aborted    :=  TRUE

        RESULTIS  NIL
    $)

    IF  testflags( #B1000 )  THEN
        message( "Line %N of file *"%S*"", linenumber, filename )
$>TRIPOS

$<MINOS
    IF  testflags( #B0001 )  THEN
    $(
        //  Break.  Set the "end of file" and "aborted" flags.

        errormessage( "BREAK." )

        endoffile  :=  TRUE
        aborted    :=  TRUE

        RESULTIS  NIL
    $)
$>MINOS

    //  This is a new line, so increase the line number.

    linenumber  :=  linenumber + 1

    $(  //  Loop to continue reading lines from the file until a real
        //  line terminator is found.

        LET length     =  0
        LET lineentry  =  0
        LET linechars  =  0

        ch  :=  readch()

        UNTIL  ch = '*N'  |  ch = '*C'  |  ch = '*P'  |  ch = endstreamch  DO
        $(
            LET repeatcount  =  1

            IF  ch = '*T'  THEN
            $(
                //  This is a tab character which we should expand into
                //  spaces.

                ch           :=  '*S'
                repeatcount  :=  8 - (length REM 8)
            $)

            FOR  i = 1  TO  repeatcount  DO
            $(
                length               :=  length + 1
                linebuffer % length  :=  ch

                IF  length = linebufferlength  THEN
                $(
                    errormessage( "Line %N of file *"%S*" truncated",
                                   linenumber, filename )

                    UNTIL  ch = '*N'  |  ch = '*C'  |  ch = endstreamch  DO
                        ch  :=  readch()

                    GOTO  endofline
                $)
            $)

            ch  :=  readch()
        $)

    endofline:

        //  We drop out of that loop with a buffered record in "linebuffer" and
        //  the length of the line in "length".  The character which terminated
        //  the record is in "ch".  We now add this line to the list of lines
        //  gathered already, and look for more.


        IF  ch = '*P'  THEN

            //  This case is special, since *P is more a prefix than a
            //  terminator.  Hopefully there will be nothing on the line,
            //  in which case we can ignore it, otherwise we have to
            //  generate a spurious '*N'

            TEST  length = 0  &  lineentry = 0  THEN  RESULTIS  print.newpage
            ELSE
            $(
                unrdch()

                ch  :=  '*N'
            $)

        IF  ch = endstreamch  THEN

            //  If we have found "endstreamch" without a preceding "*N", then
            //  we must insert one.  If we really have hit end of file, then
            //  we don't want to print the null line.

            TEST  length = 0  &  lineentry = 0  THEN
            $(
                endoffile  :=  TRUE

                BREAK
            $)
            ELSE
        
                //  We should terminate this line artificially by adding a
                //  newline to the end.  The end of stream condition will be
                //  picked up the next time round.
                
                ch  :=  '*N'

        //  There are characters buffered up, and so we had better print them.

        linebuffer % 0           :=  length
        lineentry                :=  getlineentry( length )
        linechars                :=  lineentry + le.chars

        lineentry!le.overprint   :=  line
        lineentry!le.linenumber  :=  numbering  ->  (line = NIL  ->  linenumber,
                                                                    -linenumber),  0

        FOR  i = 0  TO  length  DO  linechars % i  :=  linebuffer % i

        line  :=  lineentry
    $)
    REPEATWHILE  ch = '*C'

    //  When we drop out of that loop, we have an entire line in our hand
    //  We should return this forthwith to the caller.

   RESULTIS  line
$)



AND getpagevec()  =  getvector( maxcolumns )



AND getcolumnvec()  =  getvector( linespercolumn )



AND getfileentry()  =  getvector( fl.size )



AND getlineentry( chars )  =  getvector( le.size + chars/bytesperword )



AND getvector( size )  =  VALOF
$(
    LET words   =  size + 1
    LET vector  =  getvec( words )

    IF  vector = 0  THEN  abort( error.nospace )

    FOR  i = 1  TO  words  DO  vector!i  :=  NIL

    vector!0    :=  words
    totalwords  :=  totalwords + words

    IF  totalwords > maxtotalwords  THEN  maxtotalwords  :=  totalwords

    RESULTIS  vector + 1
$)



AND freevector( vector )  BE
$(
//  Free the vector "vector", keeping account of the amount of store used.

    LET v  =  vector - 1

    totalwords  :=  totalwords - v!0

    freevec( v )
$)



AND errormessage( format, arg1, arg2, arg3 )  BE
$(
//  Print out a message, but set final return code, so that we can
//  stop a command sequence.

    message( format, arg1, arg2, arg3 )

    returncode  :=  20
$)



AND message( format, arg1, arg2, arg3 )  BE

//  Write out an error message.  We cannot do this though, if we are printing
//  to the standard output stream, and we do not have a special error stream.

    UNLESS  standardoutput  &  (sysout = syserr)  DO
    $(
        LET o  =  output()
        LET w  =  wrch

        wrch  :=  syswrch

        selectoutput( syserr )
        writef( "****** %S:  ", commandname )
        writef( format, arg1, arg2, arg3 )
        newline()

        wrch  :=  w

        selectoutput( o )
    $)



AND readch()  =  VALOF
$(
    LET ch  =  rch()

$<VAXUNIX'
    WHILE  ch = '*E'  DO  ch  :=  rch()
$>VAXUNIX'

    RESULTIS  ch = endstreamch  ->  ch,  c( ch )
$)



AND c( char )  =      //  N.B.  ASCII specific!

    ( "?????????*T*N?*P*C?????????????????? !*"#$%&'()**+,-./0123456789:;*
      *<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~?"
    ) % (char + 1)



AND rch()  =  VALOF   //  N.B.  ASCII specific!
$(
//  Read a character, stripping parity.

    LET ch  =  rdch()

    RESULTIS  ch = endstreamch  ->  ch,  (ch & #X7F)
$)



$<TRIPOS
AND copktwait( id, pkt )  =  cowait( pkt )
$>TRIPOS



AND stringinput( string )  BE
$(
    stringbuff   :=  copystring( string )
    stringbuffb  :=  0
    stringbuffe  :=  stringbuff % 0

    rdch         :=  string.rdch
    unrdch       :=  string.unrdch
$)



AND endstringinput()  BE
$(
    freevector( stringbuff )

    rdch    :=  blib.rdch
    unrdch  :=  blib.unrdch
$)



AND string.rdch()  =  VALOF
$(
    stringbuffb  :=  stringbuffb + 1

    RESULTIS  stringbuffb > stringbuffe  ->  endstreamch,
                                             stringbuff % stringbuffb
$)



AND string.unrdch()  =  VALOF
$(
    IF  stringbuffb = 0  THEN  RESULTIS  FALSE

    stringbuffb  :=  stringbuffb - 1

    RESULTIS  TRUE
$)



AND pswrch( ch )  BE
$(
//  Write out a postscript character, performing space compaction.

    LET w  =  wrch

    wrch  :=  syswrch

    IF  newpagepending  THEN
    $(
        UNLESS  pagenumber = 1  DO  writes( "newpage pagesave restore*N" )

        writef( "%%%%Page:  %N ?*N", pagenumber )

        writes( "/pagesave save def*N" )

        newpagepending  :=  FALSE
    $)


    TEST  ch = '*S'  THEN

        //  Perform space compaction here.  Keep a count of the number of
        //  spaces we have received.

        spacecount  :=  spacecount + 1

    ELSE
    $(
        //  Spaces to write out.  If it would be more efficient to print them
        //  out as simple characters, then do that.  Otherwise, output a
        //  function call.

        TEST  spacecount < (postscriptflag -> 8, 4)  THEN
            FOR  i = 1  TO  spacecount  DO
                psbinwrch( '*S' )

        ELSE
        $(
            //  Write out a function call.  Close the postscript string
            //  if necessary.

            IF  postscriptflag  THEN  psclose()

            writef( "%N s ", spacecount )
        $)

        spacecount  :=  0

        psbinwrch( ch )
    $)

    wrch  :=  w
$)



AND psbinwrch( ch )  BE
$(
//  Write out the character given in a postscript manner.  This means
//  putting straight text within parentheses, escaping some characters, and
//  turning carriage controls into functions.

    TEST  ch = '*N'  |  ch = '*C'  |  ch = '*P'  THEN
    $(
        //  Carriage control, so close any text item which has been opened.

        IF  postscriptflag  THEN  psclose()

        //  Now write the function name corresponding to the carriage control
        //  character we have been given.

        writes( ch = '*N'  ->  "n*N",
                ch = '*C'  ->  "cr ",
             /* ch = '*P' */   "" )

        IF  ch = '*P'  THEN  newpagepending  :=  TRUE
    $)
    ELSE
    $(
        //  A normal character, so open a text item, if there isn't one
        //  currently open.

        IF  postscriptcount = maxpostscriptcount  THEN  psclose()

        UNLESS  postscriptflag  DO  psopen()

        //  Write an escape character, if one is necessary.

        IF  ch = '('  |  ch = ')'  |  ch = '\'  THEN  wrch( '\' )

        wrch( ch )

        postscriptcount  :=  postscriptcount + 1
    $)
$)



AND psopen()  BE
$(
//  Open a postscript string.

    wrch( '(' )

    postscriptflag  :=  TRUE
$)



AND psclose()  BE
$(
//  Close a postscript string.

    writes( ")p " )

    postscriptflag   :=  FALSE
    postscriptcount  :=  0
$)




AND islist()  =  VALOF
$(
//  Look at the input stream, and decide whether we are a "PRINT" or "LIST"
//  command.  Before anything else, skip over the leading part of the command
//  name "if any".

    LET ch    =  rdch()
    LET name  =  0
    LET list  =  0

    UNTIL  isterminator( ch )  DO  ch  :=  rdch()

    //  Now read backwards in the file until we hit the beginning of the
    //  string, or a file name separator.

    WHILE  unrdch()  &  unrdch()  DO
    $(
        ch  :=  uppercase( rdch() )

        IF  ch = '.'  |  ch = ':'  THEN  BREAK
    $)

    name  :=  readstring()
    list  :=  compstring( name, "LIST" )  =  0

    freevector( name )

    RESULTIS  list
$)



$<MINOS
AND abort( code, arg )  BE  fault( code, arg )
$>MINOS


