#PROGRAM       /GPFHALLOC(15AM,22AM,DBM,EBM)
#PAGE

#INCLUDE       IOHEAD(/DEFS)
#INCLUDE       STACK(/DEFS)

#PROGRAM

#              Allocate a *FH device

#              fd = fhalloc (fd, unit, type, read, write)
#              fd:    requested FD or -1
#              unit:  *FHn
#              type:  *FR, *FW, or *FH
#              read:  #1 or nothing
#              write: #2, or #22 or nothing

#              Returns FD in X6, or -ve on error
#              returns FDESC in X3 if no error

#              Local stack frame:

#SET           STFRAME=SXFRAME

#              First the arguments:

#DEFINE        STFD=SXPAR1
#SET           STFRAME=STFRAME+1

#DEFINE        STUNIT=SXPAR2
#SET           STFRAME=STFRAME+1

#DEFINE        STTYPE=SXPAR3
#SET           STFRAME=STFRAME+1

#DEFINE        STREAD=SXPAR4
#SET           STFRAME=STFRAME+1

#DEFINE        STWRITE=SXPAR5
#SET           STFRAME=STFRAME+1

#              Then the local variables:

#DEFINE        STREDTAPE=STFRAME
#SET           STFRAME=STFRAME+1

#DEFINE        STPERI=STFRAME
#DEFINE        STREPLY=STPERI+1
#DEFINE        STCOUNT=STPERI+2
#DEFINE        STADDR=STPERI+3
#DEFINE        STBUF=STPERI+4
#SET           STFRAME=STFRAME+5

      BEGIN 2  3,1,STFRAME

      LDX   4  STUNIT(2)
      LDX   3  STTYPE(2)

      NGN   6  EBADF
      ALLOT 4  256(3)                 [ is *Fxn assigned?
      LDXC  0  9                      [ allot reply in word 9!
      BCS      OUT                    [ not assigned, return -ve

      LDCT  0  256(3)                 [ move type+256 to count
      ADN   0  #12                    [ mode #12 = enquire
      STO   0  STPERI(2)

      LDN   0  1                      [ 1 word
      STO   0  STCOUNT(2)
      LDN   0  STBUF(2)               [ buffer addr
      STO   0  STADDR(2)

      PERI  4  STPERI(2)              [ get file type
      LDXC  0  STREPLY(2)             [ finished?
      BCC      *+2                    [ yup
      SUSBY 4  256(3)                 [ assume it works

      LDN   5  0                      [ No red tape
      NGN   7  1                      [ amorphous

      LDXC  0  STBUF(2)               [ B0 clear if AMORPHOUS
      BCC      ALLO

      LDN   5  #0041                  [ set initial red tape
      LDN   7  0                      [ unshifted
      
      ANDN  0  #7777                  [ get low bits of reply
      SBN   0  #12                    [ is it GRAPHIC?
      BZE   0  ALLO

      LDN   5  #7441                  [ it's a shift file
      LDN   7  #74                    [ set initial shift

ALLO  STO   5  STREDTAPE(2)           [ save red tape

      LDN   6  2004                   [ record length for *FHn is 2004
      LDN   0  #22                    [ block read?
      BXU   0  STREAD(2),*+2          [ jif not
      LDN   6  2048                   [ read whole block

      STACK 1
      LDX   0  STFD(2)                
      STO   0  SXPAR1(1)              [ fd wanted
      STO   7  SXPAR2(1)              [ initial shift
      STO   3  SXPAR3(1)              [ device type
      STO   4  SXPAR4(1)              [ Unit #
      LDX   0  STREAD(2)              [ get read mode
      STO   0  SXPAR5(1) 
      LDX   0  STWRITE(2)             [ get write mode
      STO   0  SXPAR6(1)
      STO   6  SXPAR7(1)              [ buffer length
      CALL  1  GPFDALLOC

      BNG   6  OUT

#              FDALLOC leaves FDESC in X3

      LDX   0  FDWRITE(3)              [ can we write?
      BZE   0  READ                    [ if not don't want red tape

      LDX   5  STREDTAPE(2)            [ get red tape
      BZE   5  OUT                     [ nothing to do if none

      STO   5  FDREDTAPE(3)            [ set red tape

      LDN   0  FLAGWRITE
      ANDX  0  FDFLAGS(3)              [ are we in read mode?
      BNZ   0  WRITE                   [ need space for redtape if not

#              For block mode we need to set FDRECORD to point to
#              start of buffer and zero out the length field.

READ  LDN   0  #22                     [ block read?
      BXU   0  STREAD(2),OUT           [ jif not
      LDX   1  FDADDR(3)               [ get buffer addr
      STO   1  FDRECORD(3)             [ save as next rec for blockmode
      STOZ     0(1)                    [ which is empty
      BRN      OUT

#              Leave space in buffer for red tape

WRITE LDN   5  4                       [ 4 chars used in buf
      ADS   5  FDCHARS(3)
      LDN   5  1
      ADS   5  FDNEXT(3)               [ next word for output

OUT   END   2  1,0

#END
#FINISH