[INHERIT ('SYS$LIBRARY:STARLET')]PROGRAM vq(LOGFILE);

{

This software is provided at no charge, and there is
no warranty. Permission to copy is granted without
conditions.

        David A. Johnson
        VAX System Manager
        Lockheed Palo Alto Research Lab
        Dept. 5233, Bldg 255
        3251 Hanover St.
        Palo Alto, CA 94304
        (415) 858-4038

                                               }


CONST

  maxq = 1;
  max_q_mgr = 15;       { Number of "privileged" users permitted. }

  do_accounting = 1;    { 1 to turn on accounting code }


  enable        = 1;
  disable       = 0;

  errlog = 'SYS$MANAGER:PSPOOL.LOG';
  priv_file = 'SYS$MANAGER:QPRIVS.DAT';  { File contains list of
                                           Privileged users.  }

TYPE


  byte = [BYTE]-128..127;
  word = [WORD]-32768..32767;
  longword = INTEGER;
  quadword = PACKED ARRAY [1..2] OF INTEGER;
  
  alfa4  = PACKED ARRAY [1.. 4] OF CHAR;
  alfa6  = PACKED ARRAY [1.. 6] OF CHAR;
  alfa8  = PACKED ARRAY [1.. 8] OF CHAR;
  alfa9  = PACKED ARRAY [1.. 9] OF CHAR;
  alfa12 = PACKED ARRAY [1..12] OF CHAR;
  alfa13 = PACKED ARRAY [1..13] OF CHAR;
  alfa15 = PACKED ARRAY [1..15] OF CHAR;
  alfa16 = PACKED ARRAY [1..16] OF CHAR;
  alfa17 = PACKED ARRAY [1..17] OF CHAR;
  alfa18 = PACKED ARRAY [1..18] OF CHAR;
  alfa19 = PACKED ARRAY [1..19] OF CHAR;
  alfa24 = PACKED ARRAY [1..24] OF CHAR;
  alfa26 = PACKED ARRAY [1..26] OF CHAR;
  alfa30 = PACKED ARRAY [1..30] OF CHAR;
  alfa33 = PACKED ARRAY [1..33] OF CHAR;
  alfa48 = PACKED ARRAY [1..48] OF CHAR;
  alfa63 = PACKED ARRAY [1..63] OF CHAR;
  alfa132= PACKED ARRAY [1..132] OF CHAR;

%INCLUDE 'PLTSEC.PAS/LIST'

dbl = PACKED RECORD
         pq1,pq2:secptr;
    END;

  two_wrds = PACKED ARRAY [1..2] OF word;

  equiv = PACKED RECORD
        CASE INTEGER OF
                 1:(alpha:alfa4);
                 2:( numb:INTEGER);
                 3:( twin:two_wrds)
        END;

ioblock = PACKED RECORD
                iostat,byte_count:word;
                process_id:INTEGER
          END;

nmsg = 0..3;

action_type = (plot, tex_plot, delete, initq, delq, startq, stopq,
               set_device, scrub, new_log, no_log, nogood);

mact = (stop_q_next, restart);

VAR

  equic:[VOLATILE]equiv;
  p:[VOLATILE]secptr;
  rnam,snam:alfa6;
  rchan,schan:[VOLATILE]word;
  proc_nam:alfa8;
  idx:INTEGER;
  blanks:alfa132;
  job_no:[VOLATILE]INTEGER;       { Current Entry # }
  vqabort,logon,out_of_qplot:[VOLATILE]BOOLEAN;
  five_sec:[VOLATILE]quadword;
  pschan:[VOLATILE]word;  { Mailbox channels }
  active_pid:[VOLATILE]longword;
  proc_name:alfa16;
  release_plotter:[VOLATILE]BOOLEAN;  { Flag to deallocate when through }
  LOGFILE:[VOLATILE]TEXT;

{/******************************************************\
 |                                                      |
 |                      Externals                       |
 |                                                      |
 \******************************************************/}


PROCEDURE useropen (VAR chan,stat:INTEGER);EXTERN;

[ASYNCHRONOUS,UNBOUND]PROCEDURE accounting(%STDESCR nm:alfa4; 
          %STDESCR un:alfa12;uic,cpu,dio:INTEGER);EXTERN;

[ASYNCHRONOUS,UNBOUND]PROCEDURE fdel(fn:alfa63;len:byte);EXTERN;

PROCEDURE addr1(VAR adr:dbl);EXTERN;

[ASYNCHRONOUS,UNBOUND]PROCEDURE get_status(pid:INTEGER;
		VAR sf:INTEGER;%STDESCR dev:alfa6);EXTERN;

[ASYNCHRONOUS,UNBOUND]PROCEDURE wait(x:REAL);EXTERN;

[ASYNCHRONOUS,UNBOUND]PROCEDURE wakeup(x:INTEGER);EXTERN;

[ASYNCHRONOUS,UNBOUND]FUNCTION sys$qio(%IMMED efn,chan,func:INTEGER;
                          VAR iosb:ioblock;
                          %IMMED astadr,astprm:INTEGER;
                          %IMMED [UNBOUND] PROCEDURE asthdlr;
                          %IMMED p2,p3,p4,
                                p5,p6:INTEGER):INTEGER;EXTERN;



{/******************************************************\
 |                                                      |
 |                     MODIFY_QUEUE			|
 |                                                      |
 \******************************************************/}

PROCEDURE modify_queue(qdes:alfa4; mod_action:mact);

TYPE

  smbmsg = PACKED RECORD
      CASE BOOLEAN OF

	 TRUE:(request:word;
	           qnl:byte;
	       quename:alfa15);

	FALSE:(smb:alfa18);

	END;

VAR
  st,k:INTEGER;
    qp:smbmsg;
  smbbuf:alfa18;

BEGIN
IF logon THEN WRITELN(LOGFILE, ' ...in MODIFY_QUEUE...');
WITH qp DO
  BEGIN
  quename := '               ';
  qnl := 4;
  FOR k := 1 TO 4 DO quename[k] := qdes[k];
  CASE mod_action OF

    stop_q_next : request := smr$k_stop;

        restart : request := smr$k_start

            END;

  FOR k := 1 TO 18 DO smbbuf[k] := qp.smb[k];

  st := $sndsmb(smbbuf, 0);

  END;
END;


{/******************************************************\
 |                                                      |
 |                     CVTI4    			|
 |                                                      |
 \******************************************************/}

  [ASYNCHRONOUS,UNBOUND]PROCEDURE cvti4 (k:INTEGER; VAR a:alfa4);
  VAR
    m,n:INTEGER;
  BEGIN
  n := k;
  FOR m := 4 DOWNTO 1 DO
    BEGIN
    a[m] := chr((n MOD 10) + ord('0'));
    n := n DIV 10;
    END;
  END;


{/******************************************************\
 |                                                      |
 |                       CVTHEX 			|
 |                                                      |
 \******************************************************/}

[ASYNCHRONOUS,UNBOUND]PROCEDURE cvthex(x:INTEGER;VAR y:alfa8);
 
VAR
  digit:alfa16;
  k,rem:INTEGER;
BEGIN
digit := '0123456789ABCDEF';
k := 8;
y := '00000000';
REPEAT
  rem := x MOD 16;
  y[k] := digit[rem+1];
  k := k -1;
  x := x DIV 16;
UNTIL (x=0) OR (k=0);
END;


{/******************************************************\
 |                                                      |
 |                       DEBUG  			|
 |                                                      |
 \******************************************************/}

[ASYNCHRONOUS,UNBOUND]PROCEDURE debug(info:alfa6);
BEGIN
  IF logon THEN WRITELN(LOGFILE, ' Debug at ', info);  
END;

{/******************************************************\
 |                                                      |
 |                       SAYDONE                        |
 |                                                      |
 \******************************************************/}

[ASYNCHRONOUS,UNBOUND]PROCEDURE saydone;

VAR

  pr,en,lnk,sflag,k,st:INTEGER;
  dmsg:alfa24;
  alf:alfa4;
  apid:alfa8;
  bdev:alfa6;    

BEGIN
debug('saydon');
lnk := p^.qhead.link1;
 WITH p^.qinfo[lnk].job_head DO
  BEGIN
  pr := pid;
  en := entry_no;
  get_status(pr, sflag, bdev);
  CASE sflag OF
    1:wakeup(pr);
    2:BEGIN
      cvti4(en, alf);
      dmsg := ' Plot #xxxx is finished.';
      FOR k := 1 TO 4 DO dmsg[k+7] := alf[k];
      st := $brdcst(dmsg, bdev);
      END
    END;  { CASE }
  END;

cvthex(pr, apid);
IF logon THEN 
  BEGIN
  WRITE(LOGFILE, ' Pid, sflag, entry: ');
  WRITE(LOGFILE, apid, sflag:3, ' ', en:4);
  WRITELN(LOGFILE);
  END;

END;

{/******************************************************\
 |                                                      |
 |                    INITIALIZE_VQ                     |
 |                                                      |
 \******************************************************/}

PROCEDURE initialize_vq;
VAR
  delta_string:alfa6;
  k,st:INTEGER;
  ch:CHAR;

BEGIN
out_of_qplot := TRUE;
vqabort := FALSE;
logon := TRUE;
release_plotter := FALSE;
FOR st := 1 TO 132 DO blanks[st] := ' ';
delta_string := '0 ::05';
st := $bintim(delta_string, five_sec);
proc_nam := 'PLOTSYM1';
rnam := 'VQRMB1';
snam := 'VQSMB1';
rchan := 0;
schan := 0;
OPEN(LOGFILE, errlog, NEW);
rewrite(LOGFILE);
END;

{/******************************************************\
 |                                                      |
 |                    SET_Q_MANAGERS                    |
 |                                                      |
 \******************************************************/}

PROCEDURE set_q_managers;
VAR
  qprivs:TEXT;
  line:alfa19;
  ids:ARRAY [1..20] OF INTEGER;
  a,b,k,np:INTEGER;

  BEGIN
  np := 0;
  OPEN (qprivs, priv_file, READONLY);
  RESET(qprivs);
  WHILE (NOT EOF(qprivs)) AND (np < max_q_mgr) DO
    BEGIN
    READLN(qprivs, line);
    np := np + 1;
    FOR k := 1 TO 19 DO 
      IF Line[k]=' ' THEN line[k] := '0';
    a := 0;
    b := 0;
    FOR k := 1 TO 3 DO a := 8*a + ord(line[k]) - ord('0');
    FOR k := 4 TO 6 DO b := 8*b + ord(line[k]) - ord('0');
    ids[np] := 65536*a + b;
    END;
  CLOSE(qprivs);
  p^.no_of_mgrs := np;
  FOR k := 1 TO np DO p^.q_mgrs[k] := ids[k];
  END;

{/******************************************************\
 |                                                      |
 |                      KILL_PLOT                       |
 |                                                      |
 \******************************************************/}

[ASYNCHRONOUS,UNBOUND]PROCEDURE kill_plot;

VAR

  id,stat:INTEGER;
  st1,st2,st3,st4:INTEGER;

BEGIN
debug('Killpl');

id := p^.qhead.sub_proc; 
IF id <> 0 THEN
  BEGIN
{ stat := $delprc(id); }
  p^.qhead.sub_proc := 0;
  active_pid := 0;
  st1 := $delmbx(rchan);
  st2 := $delmbx(schan);
  st3 := $dassgn(rchan);
  st4 := $dassgn(schan);
  WITH p^.qhead DO
    status := status - [plotting] + [waiting]; 
  wait (1.0);
  END;
END;

{/******************************************************\
 |                                                      |
 |                      ZAP_FILE                        |
 |                                                      |
 \******************************************************/}

[ASYNCHRONOUS,UNBOUND]PROCEDURE zap_file(a:fdtype);
VAR
  nc,k:INTEGER;
  len:byte;
  image:alfa63;
BEGIN
IF logon THEN WRITE(LOGFILE, ' Zapping ');
WITH a DO
  BEGIN
  FOR k := 1 TO dlen DO image[k] := dir_name[k];
  FOR k := 1 TO flen DO image[dlen+k] := f_name[k];
  len := dlen + flen;
  nc := len;
  IF logon THEN 
    BEGIN
    FOR k := 1 TO nc DO WRITE(LOGFILE, image[k]);
    WRITELN(LOGFILE);
    END;
  fdel (image, len);
  END;
END;

{/******************************************************\
 |                                                      |
 |                    REMOVE_ENTRY                      |
 |                                                      |
 \******************************************************/}

[ASYNCHRONOUS,UNBOUND]PROCEDURE remove_entry(jno:INTEGER;VAR ok:BOOLEAN; 
	abrt:BOOLEAN);

LABEL
  99;

VAR

  st,id,k,m,nidx,idxt:INTEGER;
  idx:ARRAY [1..3] OF INTEGER;
  found:BOOLEAN;

PROCEDURE dosub;
BEGIN
WITH p^.qinfo[idxt].job_head DO
  BEGIN
  idx[2] := vec_link;
  idx[3] := parm_link;
  link := idx[2];
  IF no_delete=0 THEN
    BEGIN
    zap_file(p^.qinfo[idx[2]].file_descr);
    IF idx[3]<>0 THEN
      zap_file(p^.qinfo[idx[3]].file_descr);
    END;
  END;
nidx := 2;
IF idx[3] = 0 THEN
  p^.qinfo[idx[2]].srpls.link := p^.control.flhead
ELSE
  BEGIN
  p^.qinfo[idx[2]].srpls.link := idx[3];
  p^.qinfo[idx[3]].srpls.link := p^.control.flhead;
  nidx := 3;
  END;
p^.control.flhead := idx[1];
FOR m := 1 TO nidx DO
 WITH p^.qinfo[idx[m]].srpls DO
  BEGIN
  FOR k := 1 TO 14 DO fill[k] := 0;
  idtag := '*MT*';
  END;
END;

BEGIN
debug('Rement');
ok := TRUE;
idx[1] := p^.qhead.link1;
IF idx[1] = 0 THEN
  BEGIN
  ok := FALSE;
  GOTO 99;
  END;

IF (jno=0) OR (p^.qinfo[idx[1]].job_head.entry_no = jno) THEN
        BEGIN
        p^.qhead.link1 := p^.qinfo[idx[1]].job_head.link;
        p^.control.working := 0;
        idxt := idx[1];
        WITH p^.qinfo[idx[1]].job_head DO
          BEGIN
          id := p^.qhead.sub_proc;
          IF (id<>0) AND abrt THEN st:=$delprc(id);
          kill_plot;
          END;
        END
ELSE
  BEGIN
  found := FALSE;
  REPEAT
    idxt := p^.qinfo[idx[1]].job_head.link;
    IF idxt <> 0 THEN
      IF p^.qinfo[idxt].job_head.entry_no = jno THEN found := TRUE
      ELSE idx[1] := idxt;
  UNTIL found OR (idxt = 0);
  IF NOT found THEN
    BEGIN
    ok := FALSE;
    GOTO 99;
    END
  ELSE
    BEGIN
    p^.qinfo[idx[1]].job_head.link := p^.qinfo[idxt].job_head.link;
    idx[1] := idxt;
    END;
  END;

dosub;

WITH p^.qhead DO 
  BEGIN
  entries := entries - 1;
  IF entries = 0 THEN status := status - [waiting] + [idle];
  END;

99:END;                 { remove_entry }

{/******************************************************\
 |                                                      |
 |                      QPLOT_AST                       |
 |                                                      |
 \******************************************************/}

[ASYNCHRONOUS,UNBOUND]PROCEDURE qplot_ast;

{ This is the guy that handles the software interrupt 
  generated when a user writes to the PLSMBX mailbox.
  The mailbox is primed to generate the interrupt
  in PROCEDURE listen_to_users.

                                                        }
LABEL

  99;

VAR
  c:alfa132;
  iosb:ioblock;
  st0,st1,st2,nch:INTEGER;
  plot_entry,qid:INTEGER;
  ndev,nf1,nf2:INTEGER;
  pkt1,pkt2,pkt3:INTEGER;
  m,k,lnk1,lnk2,npath:INTEGER;
  ct:quadword;
  tag,userq:alfa4;
  username:alfa12;
  jno:alfa4;
  dev:alfa6;
  ok:BOOLEAN;
  reply:alfa8;
  action:action_type;

  PROCEDURE answer_user;
  
  VAR

    k,st1,st2,st3:INTEGER;
    unit:alfa6;
    b:alfa132;
    repchan:word;
    iosb:ioblock;

  BEGIN
  {
     Prepare a reply to the Requestor.
                                        }
  FOR k := 1 TO 8 DO b[k] := reply[k];
  unit := 'PRMBxx';
  unit[5] := c[9];
  unit[6] := c[10];
  st1 := $assign(unit, repchan);
  st2 := $qiow(0, repchan, io$_writevblk+io$m_now,
        iosb, , 0, b, 8, 0, 0, 0, 0);
  st1 := $dassgn(repchan);
  END;

BEGIN
debug('QP-ast');
{ st1 := $setast(disable); }
st2 := $qiow(0, pschan, io$_readvblk, iosb, 
        , 0, c, 132, 0, 0, 0, 0);
nch := iosb.byte_count;
IF logon THEN 
  BEGIN
  FOR k := 1 TO 12 DO WRITE(LOGFILE, c[k]); 
  WRITELN(LOGFILE);
  END;
FOR k := 1 TO 4 DO tag[k] := c[k];
FOR k := 1 TO 4 DO userq[k] := c[k+4];

IF tag = 'PLOT' THEN action := plot
ELSE IF tag = 'PTEX' THEN action := tex_plot
ELSE IF tag = 'PDEL' THEN action := delete
ELSE IF tag = 'INIQ' THEN action := initq
ELSE IF tag = 'DELQ' THEN action := delq
ELSE IF tag = 'STRT' THEN action := startq
ELSE IF tag = 'STOP' THEN action := stopq
ELSE IF tag = 'SETD' THEN action := set_device
ELSE IF tag = 'SCRB' THEN action := scrub
ELSE IF tag = 'ILOG' THEN action := new_log
ELSE IF tag = 'NLOG' THEN action := no_log
ELSE action := nogood;

IF action IN [plot, tex_plot, delete] THEN
  FOR k := 1 TO 12 DO username[k] := c[k+12];

CASE action OF

  plot,tex_plot:
    BEGIN
    p^.qhead.structure_busy := TRUE;
    ndev := ord(c[33]);
    nf1  := ord(c[34]);
    nf2  := ord(c[35]);
{
        Now enter it in the data base.
    Extract three packets from the free list.
                                                }
    pkt1 := p^.control.flhead;
    pkt2 := p^.qinfo[pkt1].job_head.link;
    pkt3 := p^.qinfo[pkt2].job_head.link;
    p^.control.flhead := p^.qinfo[pkt3].job_head.link;
{
    Build the Job Header.
                                }
    WITH p^.qinfo[pkt1].job_head DO
      BEGIN
      link := 0;
      user_name := username;
      st1 := $gettim(ct);
      entry_time := ct;
      hold_flag := 0;
      IF c[11] = 'N' THEN no_delete := 1
                     ELSE no_delete := 0;
      IF c[12] = 'N' THEN notify := 1
                     ELSE notify := 0;
      IF action = plot THEN processor := 1
      ELSE IF action = tex_plot THEN processor := 2
      ELSE processor := 0;
      priority  := 4;
      parm_link := pkt2;
      vec_link  := pkt3;
      job_no := job_no + 1;
      IF job_no > 9999 THEN job_no := 1001;
      p^.control.last_jobno := job_no;
      entry_no := job_no;
      FOR k := 1 TO 4 DO equic.alpha[k] := c[k+24];
      uic := equic.numb;
      FOR k := 1 TO 4 DO equic.alpha[k] := c[k+28];
      pid := equic.numb;
      idtag := '*JH*';
      END;
{
    Fill in the File Descriptors.
                                        }
    WITH p^.qinfo[pkt2].file_descr DO
      BEGIN
      link := 0;
      device := userq;
      dlen := ndev;
      flen := nf1;
      dir_name := '                                 ';
      FOR k := 1 TO dlen DO dir_name[k] := c[k+35];
      f_name := '                 ';
      FOR k := 1 TO flen DO f_name[k] := c[k+71];
      idtag := '*FD*';
      END;
    WITH p^.qinfo[pkt3].file_descr DO
      BEGIN
      link := 0;
      device := userq;
      dlen := ndev;
      flen := nf2;
      dir_name := p^.qinfo[pkt2].file_descr.dir_name;
      f_name := '                 ';
      FOR k := 1 TO flen DO f_name[k] := c[k+89];
      idtag := '*FD*';
      END;
{
    Now link the JH to the QH.
                                }
    npath := 1;
    IF p^.qhead.link1 = 0 THEN
       p^.qhead.link1 := pkt1
    ELSE
      BEGIN
      lnk2 := p^.qhead.link1;
      REPEAT
        lnk1 := lnk2;
        npath := npath + 1;
        lnk2 := p^.qinfo[lnk1].job_head.link;
      UNTIL lnk2 = 0;
      p^.qinfo[lnk1].job_head.link := pkt1;
      END;
    WITH p^.qhead DO
      BEGIN
      entries := entries + 1;
      IF entries <> npath THEN vqabort := TRUE;
      IF idle IN status THEN
        status := (status + [waiting]) - [idle];
      END;

    p^.qhead.structure_busy := FALSE;

{
    Reply...
                                }
    cvti4 (job_no, jno);
    reply := 'NEW     ';
    FOR k := 1 TO 4 DO reply[k+4] := jno[k];
    answer_user;
    IF logon THEN WRITELN(LOGFILE, ' Queued #', jno);
    END;     { CASE plot }

  initq:
    BEGIN
    IF p^.control.flen > 0 THEN
      BEGIN
      reply := 'Q EXISTS';
      answer_user;
      END
    ELSE
      BEGIN
      WITH p^.control DO
        BEGIN
        flen := 4;
        qname := userq;
        END;
      WITH p^.qhead DO
        BEGIN
        FOR k := 1 TO 4 DO device_name[k] := c[k+4];
        lqname := '            ';
        k := 0;
        WHILE (k<=13) AND (c[k+17]<>' ') DO
          BEGIN
          k := k + 1;
          lqname[k] := c[k+16];
          END;
        lnlen := k;
        link1 := 0;
        characteristics := [];
        status := [idle, stopped];
        IF c[30] = 'Y' THEN
          BEGIN
          status := status + [print_mode];
          characteristics := characteristics + [printer_attached];
          END
        ELSE
          characteristics := [no_printer];
        END;            { WITH p^.qhead }
      reply := '**DONE**';
      answer_user;
      END;      { ELSE of IF flen > 0 }
    END;     { CASE initq  }

  set_device:
    WITH p^.qhead DO
      BEGIN
      IF status*[plotting,stopped] = [stopped] THEN
	BEGIN
        FOR k := 1 TO 4 DO device_name[k] := c[k+4];
	reply := '**DONE**';
	END
      ELSE
	reply := 'NOT*STOP';
      answer_user;
      END;

  startq:
    BEGIN
     WITH p^.qhead DO
        BEGIN
        status := status - [stopped];
        IF NOT (printer_attached IN characteristics) THEN
          BEGIN
          dev := '_xxxx:';
          FOR k := 1 TO 4 DO dev[k+1] := userq[k];
          st0 := $alloc(dev);
          END;
        END;
    reply := '**DONE**';
    answer_user;
    END;

  stopq:
    BEGIN
     WITH  p^.qhead DO
      BEGIN       
      status := status + [stopped];
        IF NOT (printer_attached IN characteristics) THEN
         IF p^.control.working = 0 THEN
          BEGIN
          dev := '_xxxx:';
          FOR k := 1 TO 4 DO dev[k+1] := device_name[k];
          st0 := $dalloc(dev,0);
          END
         ELSE
          release_plotter := TRUE;
      END;
    reply := '**DONE**';
    answer_user;
    END;

  new_log:
    BEGIN
    IF logon THEN CLOSE(LOGFILE);
    OPEN (LOGFILE, errlog, NEW);
    rewrite(LOGFILE);
    logon := TRUE;
    reply := '**DONE**';
    answer_user;
    END;

  no_log:
    BEGIN
    IF logon THEN CLOSE(LOGFILE);
    logon := FALSE;
    reply := '**DONE**';
    answer_user;
    END;

  delete:
    BEGIN
    FOR k := 1 TO 4 DO jno[k] := c[k+32];
    plot_entry := 0;
    FOR k := 1 TO 4 DO
      plot_entry := 10*plot_entry + ord(jno[k]) - ord('0');
{
    When deleting an entry from the queue, don't honor
      "/DELETE" request.
                                                        }
    lnk1 := p^.qhead.link1;
    p^.qinfo[lnk1].job_head.no_delete := 1;
    remove_entry ( plot_entry, ok, TRUE );
    IF ok THEN reply := ' Xd     '
          ELSE reply := ' NG     ';
    FOR k := 1 TO 4 DO reply[k+4] := jno[k];
    IF ok AND logon THEN WRITELN(LOGFILE, ' Deleted #', jno);
    answer_user;
    END;         { CASE delete }

  delq:
    BEGIN
    ok := FALSE;
     WITH p^.qhead DO
      BEGIN
      IF stopped IN status THEN
        BEGIN
        WHILE entries > 0 DO remove_entry( 0, ok, TRUE);
        link := 0;
        link1 := 0;
        device_name := '    ';
        status := [];
        entries := 0;
        characteristics := [];
        lnlen := 0;
        lqname := '            ';
        sub_proc := 0;
        structure_busy := FALSE;
        FOR k := 1 TO 6 DO rest[k] := 0;
        idtag := '*QH*';
        reply := '**DONE**';
        ok := TRUE;
        END
      ELSE
        reply := 'NOT*STOP';
      answer_user;
      END;
    IF ok THEN
     WITH p^.control DO
      BEGIN
      flen := 0;
      qname := '    ';
      END;
    END;

  nogood:
    BEGIN
    IF logon THEN 
      BEGIN
      WRITELN(LOGFILE, ' Tag not recognized:');
      WRITELN(LOGFILE, ' ***', tag);
      END;
    reply := 'Garbage.';
    answer_user;
    END;    { CASE nogood  }

END;      { All CASE declarations }
99:
{ st1 := $setast(enable); }
debug('wake..');
out_of_qplot := TRUE;
st2 := $wake;
END;

{/******************************************************\
 |                                                      |
 |                     END_OF_PLOT			|
 |                                                      |
 \******************************************************/}

[ASYNCHRONOUS,UNBOUND]PROCEDURE end_of_plot;

VAR
  un:alfa12;
  udev:alfa4;
  uicf,ucpu,udio,km,ordz:INTEGER;
  ok:BOOLEAN;
  stat,st1,st2,st3,st4:INTEGER;
  k,nch:INTEGER;
  c:alfa132;
  iosb:ioblock;
  qid:INTEGER;

BEGIN

st2 := $qiow(0, rchan, io$_readvblk, iosb,
                , 0, c, 132, 0, 0, 0, 0);
nch := iosb.byte_count;
IF logon THEN 
  BEGIN
  WRITELN(LOGFILE,  ' Reply from RASMX; length was ', nch:4);
  WRITE(LOGFILE, '  >');
  FOR st3 := 1 TO nch DO WRITE(LOGFILE, c[st3]);
  WRITELN(LOGFILE);
  END;
{                                  }
IF iosb.process_id = active_pid THEN
 BEGIN
 p^.control.working := 0;
 WITH p^.qhead DO
  BEGIN
  WITH p^.qinfo[link1].job_head DO
    BEGIN
    IF notify = 1 THEN saydone;
    IF do_accounting=1 THEN
      BEGIN
      ordz := ord('0');
      ucpu := 0;
      udio := 0;
      un := user_name;
      uicf := uic;
      FOR k := 1 TO 4 DO
        BEGIN
        IF c[k+9] = ' ' THEN km := 0
                      ELSE km := ord(c[k+9]) - ordz;
        ucpu := 10*ucpu + km;
        END;
      FOR k := 1 TO 6 DO
        BEGIN
        IF c[k+14] = ' ' THEN km := 0
                         ELSE km := ord(c[k+14]) - ordz;
        udio := 10*udio + km;
        END;
      udev := p^.qhead.device_name;
      IF nch < 15 THEN
	BEGIN
	ucpu := 0;
	udio := 0;
	END;
      accounting ( udev, un, uicf, ucpu, udio );
      END;
    END;  
  structure_busy := TRUE;
  status := status - [plotting];
  remove_entry( 0, ok, FALSE);
  IF entries > 0 THEN status := status + [waiting]
                 ELSE status := status + [idle];
  structure_busy := FALSE;
  END;
 END;
END;

{/******************************************************\
 |                                                      |
 |                       PLOT_FIN                       |
 |                                                      |
 \******************************************************/}

[ASYNCHRONOUS,UNBOUND]PROCEDURE plot_fin1;

{
        This handles the attention AST from VQRMBx,
        which is written into by the plot driver
        when it finishes plotting.
                                                        }

VAR

  k,st1,st2,st3,st4:INTEGER;
  dev:alfa6;

BEGIN
debug('pl-f-1');
{ st1 := $setast(disable); }
end_of_plot;
{ st3 := $setast(enable); }
IF release_plotter THEN
  BEGIN
  wait (1.0);
  dev := '_xxxx:';
  WITH p^.qhead DO
    FOR k := 1 TO 4 DO dev[k+1] := device_name[k];
  st2 := $dalloc(dev, 0);
  release_plotter := FALSE;
  END;
st4 := $wake;
END;


{/******************************************************\
 |                                                      |
 |                     REBUILD_PSEC                     |
 |                                                      |
 \******************************************************/}
PROCEDURE rebuild_psec(p:[VOLATILE]secptr);

VAR
  k,m:INTEGER;

BEGIN
job_no := 1000;
WITH p^.control DO
  BEGIN
  flhead := 1;
  flen := 0;
  qname := '    ';
  last_jobno := 1000;
  FOR k := 1 TO 4 DO pad4l[k] := 0;
  idtag := '*CX*';
  END;

WITH p^.qhead DO
  BEGIN
  link := 0;
  device_name := '    ';
  link1 := 0;
  status := [];
  entries := 0;
  characteristics := [];
  lnlen := 0;
  lqname := '            ';
  sub_proc := 0;
  FOR k := 1 TO 6 DO rest[k] := 0;
  idtag := '*QH*';
  END;

FOR m := 1 TO 155 DO
 WITH p^.qinfo[m].srpls DO
  BEGIN
  link := m + 1;
  FOR k := 1 TO 14 DO fill[k] := 0;
  idtag := '*MT*';
  END;
END;

{/******************************************************\
 |                                                      |
 |                      MAP_PLOTQ                       |
 |                                                      |
 \******************************************************/}

PROCEDURE map_plotq(VAR p:[VOLATILE]secptr);

VAR
  inadr,retadr:dbl;
  gsdnam:alfa9;
  mask,channel:longword;
  status:longword;
  protection_mask:word;
  newfile,ok:BOOLEAN;
  newsec,secok:BOOLEAN;

{/******************************************************\
 |                                                      |
 |                      RESET_PSEC                      |
 |                                                      |
 \******************************************************/}

PROCEDURE reset_psec(p:[VOLATILE]secptr);

VAR
  k,lnk:INTEGER;

BEGIN
 IF p^.control.flen > 0 THEN
  BEGIN
  WITH p^.qhead DO
    BEGIN
    lnk := link1;
    IF plotting IN status THEN 
            status := status - [plotting] + [waiting];
    status := status + [stopped];
    IF printer_attached IN characteristics THEN
      status := status + [print_mode];
    END;
  IF lnk <> 0 THEN p^.control.working := 0;
  END;
END;

BEGIN
gsdnam := 'PLOTQSECT';
mask :=   sec$m_gbl
        + sec$m_perm
        + sec$m_sysgbl
        + sec$m_wrt;
protection_mask := %X2200;

newfile := FALSE;
ok      := TRUE;
secok   := TRUE;
newsec  := FALSE;

status := 0;
useropen(channel, status);
IF status = ss$_created THEN newfile := TRUE
ELSE IF status <> ss$_normal THEN ok := FALSE;

addr1 (inadr);
IF ok THEN
  BEGIN
  status := $crmpsc(inadr, retadr, 0, mask, gsdnam,
                        0, 0, channel, 20, 0,
                        protection_mask, 0);
  IF status = ss$_created THEN newsec := TRUE
  ELSE IF status <> ss$_normal THEN secok := FALSE;
  END

ELSE

  BEGIN
  status := $mgblsc(inadr, retadr, 0, 
                        sec$m_sysgbl + sec$m_wrt,
                        gsdnam, 0, 0);
  IF status <> ss$_normal THEN secok := FALSE;
  END;

IF secok THEN p := retadr.pq1
         ELSE p := NIL;

IF secok THEN
  IF newfile THEN rebuild_psec(p)
             ELSE reset_psec(p);

IF logon THEN WRITELN(LOGFILE, ok, secok, newfile, status:12);

job_no := p^.control.last_jobno;

END;

{/******************************************************\
 |                                                      |
 |                   CREATE_MAILBOXES                   |
 |                                                      |
 \******************************************************/}

PROCEDURE create_mailboxes;

VAR
     stat,i:INTEGER;

BEGIN
stat := $crembx(1, pschan, 132, 0,0,0, 'PLSMBX');
IF (stat <> ss$_normal) AND logon THEN
                        BEGIN
                        WRITELN(LOGFILE, ' MBX CREATE NO GOOD.');
                        WRITELN(LOGFILE, ' Status was ', stat:8);
                        halt;
                        END;
END;

{/******************************************************\
 |                                                      |
 |                    LISTEN_TO_USERS                   |
 |                                                      |
 \******************************************************/}

PROCEDURE listen_to_users;
VAR
  iosb:ioblock;
  stat:INTEGER;

BEGIN
debug('listen');

stat := sys$qio(0, pschan, io$_setmode+io$m_wrtattn,
                  iosb, 0, 0, qplot_ast, 0, 0, 0, 0, 0);

IF logon THEN WRITELN(LOGFILE, ' SET AST stat is ', stat:8);
END;

{/******************************************************\
 |                                                      |
 |                    SWITCH_TO_PLOT                    |
 |                                                      |
 \******************************************************/}

PROCEDURE switch_to_plot;

VAR
  waits,st,k,n:INTEGER;
  a:alfa4;
  dev:alfa6;

BEGIN
debug('sw-plt');
a := p^.qhead.device_name;
modify_queue(a, stop_q_next);
WITH p^.qhead DO status := status - [print_mode];
dev := '_xxxx:';
FOR k := 1 TO 4 DO dev[k+1] := p^.qhead.device_name[k];
{
  Loop until device can be allocated. 
  (Run down the current print job.)
                                        }

waits := 0;
REPEAT
st := $alloc(dev);
IF logon THEN WRITELN(LOGFILE, ' Attempting allocation.. Status is ', st:8);
waits := waits + 1;
wait(2.0);
UNTIL ODD(st);

END;

{/******************************************************\
 |                                                      |
 |                      START_PLOT                      |
 |                                                      |
 \******************************************************/}

PROCEDURE start_plot;

LABEL 97;

TYPE

  quotat = PACKED RECORD
                typ:byte;
                wsquota:longword;
                deft:byte;
                wsdef:longword;
                listend:byte;
           END;

VAR
  
  pidx,vidx,pid,m,k:INTEGER;
  iosba,iosbb,iosbc,iosb1,iosb2:ioblock;
  st0,st1,st2,st3,st4,st5,st6:INTEGER;
  st01,st02,st03:INTEGER;
  nc:INTEGER;
  fn:alfa132;
  dev:alfa6;
  quota:quotat;

  FUNCTION put_name( a:fdtype ):INTEGER;
  VAR
    k:INTEGER;
  BEGIN
  fn := blanks;
  WITH a DO
    BEGIN
    FOR k := 1 TO dlen DO fn[k] := dir_name[k];
    FOR k := 1 TO flen DO fn[dlen+k] := f_name[k];
    put_name := flen + dlen;
    END;
  END;

BEGIN
debug('st-plt');
{  st0 := $setast(disable); }

IF p^.qhead.entries = 0 THEN GOTO 97;

st01 := $crembx(0, schan, 132, 0, 0, 0, snam);
st02 := $crembx(0, rchan, 132, 0, 0, 0, rnam);

WITH quota DO
  BEGIN
  typ := pql$_wsquota;
  wsquota := 250;
  deft := pql$_wsdefault;
  wsdef := 105;
  listend := pql$_listend;
  END;

m := p^.qhead.link1;
st1 := p^.qinfo[m].job_head.processor;
CASE st1 OF
  1:proc_name := 'SYS$SYSTEM:RASMX';
  2:proc_name := 'SYS$SYSTEM:PLTEX';
END;

REPEAT
st03 := $creprc( pid, proc_name,
                   snam, rnam, rnam, ,
                   quota, proc_nam, 4, 0, 0, 0);
wait(0.5);
UNTIL st03 <> ss$_duplnam;

active_pid := pid;

p^.control.working := 1;

WITH p^.qhead DO
  BEGIN
  sub_proc := pid;
  status := status - [waiting] + [plotting];
  m := link1;
  END;

WITH p^.qinfo[m].job_head DO
  BEGIN
  pidx := parm_link;
  vidx := vec_link;
  END;

nc := put_name(p^.qinfo[pidx].file_descr);
IF logon THEN 
  BEGIN
  WRITE(LOGFILE, ' PARM: ');
  WRITE(LOGFILE, nc:3, ' ');
  FOR k := 1 TO nc DO WRITE(LOGFILE, fn[k]);
  WRITELN(LOGFILE);
  END;

st2 := $qiow(0, schan, io$_writevblk+io$m_now,
                iosba, , 0, fn, nc, 0, 0, 0, 0);

IF logon THEN WRITELN(LOGFILE, ' Processor = ', st1:1);

CASE st1 OF
  1:nc := put_name(p^.qinfo[vidx].file_descr);
  2:WITH p^.qinfo[vidx].file_descr DO
      BEGIN
      nc := flen;
      IF flen > 0 THEN
        FOR k := 1 TO flen DO fn[k] := f_name[k]
      ELSE
	BEGIN
	nc := 1;
	fn[1] := ' ';
	END;
      END;
END;      { CASE st1 }

IF logon THEN 
  BEGIN
  WRITE(LOGFILE, ' VECT: ');
  WRITE(LOGFILE, nc:3, ' ');
  FOR k := 1 TO nc DO WRITE(LOGFILE, fn[k]);
  WRITELN(LOGFILE);
  END;

st3 := $qiow(0, schan, io$_writevblk+io$m_now,
                iosbb, , 0, fn, nc, 0, 0, 0, 0);

dev := '_xxxx:';
FOR k := 1 TO 4 DO dev[k+1] := p^.qhead.device_name[k];
FOR k := 1 TO 6 DO fn[k] := dev[k];
st6 := $qiow(0, schan, io$_writevblk+io$m_now,
                iosbc, , 0, fn, 6, 0, 0, 0, 0);


st4 := sys$qio(0, rchan, io$_setmode+io$m_wrtattn,
                iosb1, 0, 0, plot_fin1, 0, 0, 0, 0, 0);
97:
{
        Debug Output...
IF logon THEN 
  BEGIN
  WRITELN(LOGFILE, ' In START_PLOT.');
  WRITE(LOGFILE, ' st2-st4 were: ');
  WRITELN(LOGFILE, st2:4, ' ', st3:4, ' ', st4:4);
  WRITELN(LOGFILE, ' st01-03 were ', st01:4, ' ', st02:4, ' ', st03:4);
  END;
        End Debug Output.
                                }
{ st5 := $setast(enable); }
END;

{/******************************************************\
 |                                                      |
 |                    SWITCH_TO_PRINT                   |
 |                                                      |
 \******************************************************/}

PROCEDURE switch_to_print;
VAR
  st0,st1,k:INTEGER;
          a:alfa4;
        dev:alfa6;

BEGIN
debug('sw-prt');
dev := '_xxxx:';
a := p^.qhead.device_name;
FOR k := 1 TO 4 DO
  dev[k+1] := a[k];
st0 := $dalloc(dev,0);
modify_queue(a, restart);
WITH p^.qhead DO status := status + [print_mode];
END;

{/******************************************************\
 |                                                      |
 |                         SLEEP                        |
 |                                                      |
 \******************************************************/}

PROCEDURE sleep;
VAR
  st:INTEGER;
BEGIN
st := $hiber;
END;

{/******************************************************\
 |                                                      |
 |                         MAIN                         |
 |                                                      |
 \******************************************************/}

BEGIN
initialize_vq;
map_plotq(p);
p^.qhead.structure_busy := FALSE;
set_q_managers;
create_mailboxes;
WHILE NOT vqabort DO
  BEGIN
  debug('mn_top');
  IF out_of_qplot THEN
    BEGIN
    out_of_qplot := FALSE;
    listen_to_users;
    END;
   WITH p^.qhead DO
    IF status <> [] THEN
    BEGIN
    IF logon THEN WRITELN(LOGFILE, '...', BIN(status, 8) );
    IF (NOT (stopped IN status)) AND (waiting IN status) THEN
      BEGIN
      IF print_mode IN status THEN switch_to_plot;
      start_plot;
      END;
    IF (printer_attached IN characteristics) AND
       (status*[stopped,idle,print_mode]=[idle]) THEN
         switch_to_print;
    END;
  sleep;
  END;
IF vqabort AND logon THEN WRITELN(LOGFILE, ' VQ aborted.');
END.