home *** CD-ROM | disk | FTP | other *** search
/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / sql / rapport.src < prev    next >
Encoding:
Text File  |  1988-05-03  |  276.3 KB  |  10,049 lines
  1. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  2. --USERCALL.FOR
  3. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  4. C-------------------------------------------------------------------------
  5. C
  6. C   This program is set up as a concurrently running process on the 
  7. C Startrapport request . On receipt of a message the type of service call
  8. C required is discovered by reference to the first long word of the message
  9. C buffer , the appropriate service handler is then called .
  10. C
  11. C   After setting up the channel number to be equivalent to the mailbox
  12. C the program performs :-
  13. C
  14. C                 loop
  15. C                     { Read a message from the channel
  16. C                       Call appropriate handler
  17. C                       Write a message to the channel }
  18. C                 until EndRapport
  19. C
  20. C
  21. C   Each handler receives the values it needs by equivalence with the message
  22. C buffer and returns answers in the same way .
  23. C
  24. C   A word (INTEGER*2) message buffer is used but this is in fact not
  25. C neccesary ( it just in fact makes things more complex ) but as the program
  26. C as it stands works (and is just a demonstration) it was decided to leave well
  27. C alone.
  28. C
  29. C---------------------------------------------------------------------------
  30.  
  31.  
  32.     PROGRAM USERCALL
  33.  
  34.  
  35. C IRET is the return code from the activation of a system service .
  36.  
  37.         INTEGER*4 IRET
  38.  
  39. C SYS$ASSIGN is the system service to assign a channel number to a logical
  40. C name .
  41.  
  42.     INTEGER*4 SYS$ASSIGN
  43.  
  44. C SYS$QIOW is the system service for message passing .
  45.  
  46.         INTEGER*4 SYS$QIOW
  47.  
  48. C CHAN is the number of the channel that is connected to the mailbox .
  49.  
  50.         INTEGER*2 CHAN
  51.  
  52. C NMESS is the number of bytes to read from and write to the mailbox .
  53.  
  54.     INTEGER*2 NMESS
  55.  
  56.  
  57.  
  58. C WBUF is the message buffer that is filled from and emptied into the mailbox .
  59.  
  60.     COMMON/MSGBUF/WBUF(100)
  61.         INTEGER*2 WBUF
  62.  
  63.  
  64. C LWBUF is a long word equivalent of the INTEGER*2 message buffer .
  65.  
  66.         INTEGER LWBUF(2)
  67.         EQUIVALENCE (LWBUF,WBUF)
  68.  
  69.  
  70. C WHAT is the number of the system service required and is equivalent to the
  71. C first long word of the message buffer .
  72.  
  73.     INTEGER*4 WHAT
  74.         EQUIVALENCE (WHAT,LWBUF(1))
  75.  
  76.  
  77. C IODEF and SSDEF are the definition file for the system services and the
  78. C input output services .
  79.  
  80.         INCLUDE '($IODEF)/NOLIST'
  81.         INCLUDE '($SSDEF)/NOLIST'
  82.  
  83.  
  84.  
  85. C Actual program start :-
  86.  
  87.  
  88.         WRITE(6,900)
  89. 900     FORMAT(1X,'  Sub-Nucleus activation ..... '/)
  90.  
  91.  
  92. C NMESS is set to 200 so 200 bytes (or 50 long-words) are read from the mailbox
  93.  
  94.         NMESS=200
  95.  
  96. C The logical channel sys$error is assigned and identification channel number .
  97.  
  98.         IRET=SYS$ASSIGN('SYS$ERROR',CHAN,,)
  99.  
  100.  
  101.  
  102. C This is the main program loop if WHAt is equal to 2 then the last RAPPORT
  103. C service called was EndRapport.WHAT is first set to to 0 to ensure that
  104. C the loop is not terminated accidently.
  105.  
  106.         WHAT=0
  107.  
  108.         DO WHILE (WHAT.NE.2)
  109.  
  110.  
  111. C Read 200 bytes from the mailbox and put it into the word message buffer.
  112.  
  113.             IRET=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_READVBLK),,,,WBUF,
  114.      *                     %VAL(NMESS),,,,)
  115.  
  116. C Dispatch accordin to the value of what .
  117.  
  118.             IF (WHAT.EQ.1) CALL R8STAR
  119.             IF (WHAT.EQ.2) CALL R8ENDR    
  120.             IF (WHAT.EQ.3) CALL R8TRAN
  121.         IF (WHAT.EQ.4) CALL R8COMT
  122.         IF (WHAT.EQ.5) CALL R8BKTK
  123.         IF (WHAT.EQ.6) CALL R8INRT
  124.         IF (WHAT.EQ.7) CALL R8UPDT
  125.         IF (WHAT.EQ.8) CALL R8STOR
  126.         IF (WHAT.EQ.9) CALL R8COND
  127.         IF (WHAT.EQ.10) CALL R8FECH
  128.         IF (WHAT.EQ.11) CALL R8DELT
  129.         IF (WHAT.EQ.13) CALL R8STKY
  130.         IF (WHAT.EQ.14) CALL R8HOLD
  131.         IF (WHAT.EQ.15) CALL R8ENRV
  132.         IF (WHAT.EQ.17) CALL R8RTRV
  133.         IF (WHAT.EQ.18) CALL R8CLFI
  134.         IF (WHAT.EQ.19) CALL R8LOCK
  135.  
  136. C Write 200 bytes to the mailbox from the message buffer .
  137.  
  138.             IRET=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_WRITEVBLK),,,,WBUF,
  139.      *                     %VAL(NMESS),,,,)
  140.  
  141.  
  142.  
  143.         ENDDO
  144.  
  145.         WRITE(6 , 901)
  146. 901    FORMAT(1X,'  Sub-Nucleus shutdown .....'/)
  147.  
  148.  
  149.         STOP
  150.     END
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.     SUBROUTINE R8STAR
  158.  
  159. C------------------------------------------------------------------------------
  160. C
  161. C Function        : Fortran interface to the RAPPORT R0STAR.
  162. C                      * The routine calls RAPPORT r0star .
  163. C                      * Sets the variable LIPB to true which indicates that 
  164. C                        any data transfreal is via the ipb .
  165. C                      * Fills the common arrays NOFDS , IFPT , JWTEST .
  166. C
  167. C
  168. C Input arguments : None.
  169. C
  170. C Output arguments: None.
  171. C
  172. C Common blocks   : The common message buffer WBUF.This is equivalenced to 
  173. C                   a long word buffer to extract the StartRapport parameters.
  174. C                   RCLIPB/LIPB : LIPB is a flag which indicates where the 
  175. C                                 nucleus is to get the record data from.If it
  176. C                                 is false then this place is the FORTRAN 
  177. C                                 program buffers if true then the IPB.It is
  178. C                                 set to flase by R0STAR.
  179. C                   RCJDD/JDDATA : Holds various RAPPORT parameters.
  180. C                   RCPPRM/PARAMS : Holds various RAPPORT parameters .
  181. C                   RCFDS/NOFDS : Given the number of a file returns the number
  182. C                                 fields in that file .
  183. C                   RCFPT/IFPT : Given the number of  a file returns the number
  184. C                                of the first field in the file .
  185. C                   RCWOR/NWORRB : Given a file number returns the amount of
  186. C                                  space needed in the ipb by that file .
  187. C                   RCJWT : [?] .
  188. C                   RCIIPB/IIPB : IIPB given a file number returns an index
  189. C                                 into the ipb for that file.
  190. C                     
  191. C Called by       : Main.
  192. C
  193. C Calls           : RAPPORT : R0STAR
  194. C                   RAPPORT : R0RDUS (to fill up common areas)
  195. C
  196. C Author          : MDD                    ( 4/3/85 )     Version 1.0
  197. C
  198. C Amendments      :                        (  /  /  )
  199. C
  200. C Notes           : 
  201. C
  202. C------------------------------------------------------------------------------
  203.  
  204.  
  205.  
  206. C KNAME  is the name of the DDF that is passed to the RAPPORT R0STAR. in
  207. C our case though the DDF name will be specified from the terminal and so
  208. C Kname will be given a dummy value before the call to R0STAR.
  209.  
  210.     CHARACTER KNAME
  211.  
  212. C NKNANE is the length of the dummy dcf name .
  213.  
  214.     INTEGER NKNAME
  215.  
  216.  
  217. C LFPRES is a boolean value indicating to R0STAR whether a correct DDF
  218. C name has been specified in the call.In our case we have not so LFPRES
  219. C will be set to .FALSE.
  220.  
  221.         LOGICAL LFPRES
  222.  
  223. C FILNO is the last file accessed and is received from the message buffer
  224. C by equivalence with LWBUF (5)
  225.  
  226.         INTEGER FILNO
  227.  
  228. C JFSCU is a check sum on the file structure equivalenced from the message
  229. C buffer LWBUF (3)
  230.  
  231.       INTEGER JFSCU
  232.  
  233. C JTASK is a unique number assigned by R0STAR to identify the calling process
  234. C This is returned to the process by equivalencing JTASK to the message buffer
  235. C LWBUF (4)
  236.  
  237.     INTEGER JTASK
  238.  
  239. C JER is an indication of the success of R0STAR.Returned by equivalence to the
  240. C message buffer LWBUF (2)
  241.  
  242.     INTEGER JER
  243.  
  244. C LER is the error return from r0rdus .
  245.  
  246.     INTEGER LER
  247.  
  248.  
  249.  
  250.  
  251. C See header .
  252.  
  253.     COMMON/RCLIPB/LIPB
  254.     LOGICAL LIPB
  255.  
  256.  
  257.     COMMON/MSGBUF/WBUF(5)
  258.     INTEGER LWBUF(10)
  259.         EQUIVALENCE (LWBUF,WBUF)
  260.  
  261.  
  262.  
  263.     EQUIVALENCE (JER,LWBUF(2)) , (JFSCU,LWBUF(3))
  264.     EQUIVALENCE (JTASK,LWBUF(4)) , (FILNO,LWBUF(5))
  265.  
  266.  
  267.  
  268. C See Header .
  269.  
  270.     COMMON/RCJDD/JDDATA(18)
  271.     INTEGER JDDATA
  272.  
  273.         EQUIVALENCE ( JDDATA(1) , JFILE )
  274.         EQUIVALENCE ( JDDATA(2) , JFLPFD )
  275.         EQUIVALENCE ( JDDATA(4) , JFIELD )
  276.  
  277.  
  278. C JFILE is the number of file specified in the ddf .
  279. C JFLPFD is
  280. C JFIELD is
  281.  
  282.  
  283.     INTEGER JFILE , JFLPFD , JFIELD  
  284.  
  285.  
  286. C IFILE is a count used to fill up the iipb
  287.  
  288.     INTEGER IFILE
  289.  
  290.  
  291. C See Header .
  292.  
  293.     COMMON/RCPPRM/PARAMS(100)
  294.     INTEGER PARAMS
  295.  
  296.         EQUIVALENCE ( PARAMS(6) , MFIELD )
  297.         EQUIVALENCE ( PARAMS(7) , MFILE )
  298.         EQUIVALENCE ( PARAMS(21) , MWOFBF )
  299.         EQUIVALENCE ( PARAMS(36) , MWOIPB )
  300.         EQUIVALENCE ( PARAMS(96) , MFLPFD )
  301.  
  302.     INTEGER MFILED , MFILE 
  303.     INTEGER MWOFBF , MWOIPB , MFLPFD
  304.  
  305.  
  306. C See Header .
  307.  
  308.     COMMON/RCFDS/NOFDS(55)
  309.     COMMON/RCFPT/IFPT(55)
  310.     COMMON/RCWOR/NWORRB(55)
  311.     COMMON/RCJWT/JWTEST(301)
  312.  
  313.  
  314.  
  315.     INTEGER NOFDS , IFPT , NWORRB , JWTEST
  316.  
  317.  
  318. C See Header .
  319.  
  320.     COMMON/RCIIPB/IIPB(55)
  321.     INTEGER IIPB 
  322.  
  323.  
  324.  
  325.  
  326.  
  327.  
  328. C Before calling R0STAR the values pertaining to the DDF are set to dummy
  329. C but consistent values.KNAME is a space and the length of KNAME is 1.
  330.  
  331.         NKNAME=1
  332.     KNAME=' '
  333.     LFPRES=.FALSE.
  334.  
  335. C        WRITE(6,1000)
  336. C 1000    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0STAR'/)
  337.  
  338.     CALL R0STAR(KNAME,NKNAME,LFPRES,FILNO,JFSCU,JTASK,JER)
  339.  
  340. C        WRITE(6,1001)
  341. C 1001    FORMAT(1X,'  %USERCALL-TRACEMSG-EXITING RAPPORT R0STAR'/)
  342.  
  343.  
  344. C LIPB is set to true so that record transferal is by means of the ipb .
  345.  
  346.     LIPB=.TRUE.
  347.  
  348.  
  349.  
  350. C Fill up the common array IFPT ( Given a file number returns the number of
  351. C the first field in that file )
  352.  
  353.     CALL R0RDUS(4 , 1 , JFILE , IFPT , MFILE , 1 , RAPERR )
  354.  
  355. C Fill the common array NWORRB ( Given a file number return the amoun of space
  356. C in the ipb required to hold a record of that file ) .
  357.  
  358.     CALL R0RDUS(6 , 1 , JFILE-1 , NWORRB , MFILE , 1 , RAPERR )
  359.  
  360. C Fill the common array nofds ( Given a file number return the number of fields
  361. C in that file ) .
  362.  
  363.     CALL R0RDUS(8 ,1 , JFILE-1 , NOFDS , MFILE , 1, RAPERR )
  364.  
  365. C Fill the common array jwtest .
  366.  
  367.     CALL R0RDUS(29 , 1 , JFLPFD-1 , JWTEST , MFLPFD , 1, RAPERR )
  368.  
  369. C Fill the ipb ( given a file number returns the index into the ipb)
  370. C iipb ( n ) := iipb ( n-1 ) + Amount of space required by file n-1
  371.  
  372.     IIPB(1)=1
  373.     DO IFILE=1,JFILE-1
  374.            IIPB(IFILE+1)=IIPB(IFILE)+NWORRB(IFILE)
  375.         ENDDO
  376.  
  377.  
  378.  
  379.  
  380.  
  381.     RETURN
  382.         END
  383.  
  384.  
  385.  
  386.  
  387.     SUBROUTINE R8ENDR
  388.  
  389. C------------------------------------------------------------------------------
  390. C
  391. C Function        : Fortran interface to the RAPPORT R0ENDR.
  392. C
  393. C Input arguments : None.
  394. C
  395. C Output arguments: None.
  396. C
  397. C Common blocks   : The common message buffer WBUF which is accessed via an
  398. C                   equivalent long word buffer .
  399. C
  400. C Called by       : MAIN.
  401. C
  402. C Calls           : RAPPORT : R0ENDR.
  403. C
  404. C Author          : MDD                    (  /  /  )     Version 1.0
  405. C
  406. C Amendments      :                        (  /  /  )
  407. C
  408. C Notes           : 
  409. C
  410. C------------------------------------------------------------------------------
  411.  
  412.  
  413.  
  414. C JER is an indication of the success of R0ENDR.
  415.  
  416.     INTEGER JER
  417.  
  418.  
  419.         COMMON/MSGBUF/WBUF(10)
  420.         INTEGER LWBUF(10)
  421.      INTEGER*2 WBUF
  422.       EQUIVALENCE (LWBUF,WBUF)
  423.  
  424.         EQUIVALENCE (JER,LWBUF(2))
  425.  
  426. C    WRITE(6,200)
  427. C 200    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0ENDR'/)
  428.  
  429.         CALL R0ENDR(JER)
  430.  
  431. C    WRITE(6,201)
  432. C 201    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVIVIN RAPPORT R0ENDR'/)
  433.  
  434.         RETURN
  435.     END
  436.  
  437.  
  438.  
  439.     SUBROUTINE R8TRAN
  440.  
  441.  
  442. C------------------------------------------------------------------------------
  443. C
  444. C Function        : Fortran interface to the RAPPORT R0TRAN. 
  445. C
  446. C Input arguments : None.
  447. C
  448. C Output arguments: None.
  449. C
  450. C Common blocks   : The common message buffer WBUF which is accessed by
  451. C                   reference to an equivalent long word buffer .
  452. C
  453. C Called by       : Main.
  454. C
  455. C Calls           : RAPPORT : R0TRAN.
  456. C
  457. C Author          :                        (  /  /  )     Version 1.0
  458. C
  459. C Amendments      :                        (  /  /  )
  460. C
  461. C Notes           : 
  462. C
  463. C------------------------------------------------------------------------------
  464.  
  465.  
  466.  
  467. C NTRANS is the unique number assigned by rapport to identify this particular
  468. C transaction.
  469.  
  470.     INTEGER NTRANS
  471.  
  472. C JER is an indication of the success of R0TRAN
  473.  
  474.     INTEGER JER
  475.  
  476.  
  477.     COMMON/MSGBUF/WBUF(10)
  478.     INTEGER*2 WBUF
  479.     INTEGER LWBUF(10)
  480.     EQUIVALENCE (WBUF,LWBUF)
  481.  
  482.         EQUIVALENCE (JER,LWBUF(2)),(NTRANS,LWBUF(3))
  483.  
  484. C    WRITE(6,202)
  485. C 202    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERINR RAPPORT R0TRAN'/)
  486.  
  487.     CALL R0TRAN(NTRANS,JER)
  488. C    WRITE(6,203)
  489. C 203    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0TRAN'/)
  490.  
  491.         RETURN
  492.     END
  493.  
  494.  
  495.  
  496.     SUBROUTINE R8COMT
  497.  
  498. C------------------------------------------------------------------------------
  499. C
  500. C Function        : Fortran interface to the RAPPORT R8COMT.
  501. C
  502. C Input arguments : None.
  503. C
  504. C Output arguments: None.
  505. C
  506. C Common blocks   : The common message buffer WBUF which is accessed by
  507. C                   referace to an equivalent long word buffer .
  508. C
  509. C Called by       : Main.
  510. C
  511. C Calls           : RAPPORT R0COMT
  512. C
  513. C Author          :                        (  /  /  )     Version 1.0
  514. C
  515. C Amendments      :                        (  /  /  )
  516. C
  517. C Notes           : 
  518. C
  519. C------------------------------------------------------------------------------
  520.  
  521.  
  522.  
  523. C JER is an indication of the success of R0COMT.
  524.  
  525.     INTEGER JER
  526.  
  527.  
  528.     COMMON/MSGBUF/WBUF(10)
  529.     INTEGER*2 WBUF
  530.     INTEGER LWBUF(10)
  531.     EQUIVALENCE (WBUF,LWBUF)
  532.  
  533.       EQUIVALENCE (JER,LWBUF(2))
  534.  
  535. C    WRITE(6,204)
  536. C 204    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0COMT'/)
  537.  
  538.     CALL R0COMT(JER)
  539.  
  540. C    WRITE(6,205)
  541. C 205    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0COMT'/)
  542.  
  543.     RETURN
  544.     END
  545.  
  546.  
  547.  
  548.     SUBROUTINE R8BKTK
  549.  
  550. C------------------------------------------------------------------------------
  551. C
  552. C Function        : The fortran interface to the RAPPORT R0BKTK.
  553. C
  554. C Input arguments : None.
  555. C
  556. C Output arguments: None.
  557. C
  558. C Common blocks   : The common message buffer WBUF which is accessed by 
  559. C                   referenced to the equivalent long word buffer .
  560. C
  561. C Called by       : Main.
  562. C
  563. C Calls           : RAPPORT : R0BKTK.
  564. C
  565. C Author          :                        (  /  /  )     Version 1.0
  566. C
  567. C Amendments      :                        (  /  /  )
  568. C
  569. C Notes           : 
  570. C
  571. C------------------------------------------------------------------------------
  572.  
  573.  
  574.  
  575. C JER is an indication of the success of R0COMT.
  576.  
  577.     INTEGER JER
  578.  
  579.  
  580.     COMMON/MSGBUF/WBUF(10)
  581.     INTEGER*2 WBUF
  582.     INTEGER LWBUF(10)
  583.     EQUIVALENCE (WBUF,LWBUF)
  584.  
  585.     EQUIVALENCE (JER,LWBUF(2))
  586.  
  587. C    WRITE(6,206)
  588. C 206    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0BKTK'/)
  589.  
  590.     CALL R0BKTK(JER)
  591. C    WRITE(6,207)
  592. C 207    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0BKTK'/)
  593.  
  594.  
  595.     RETURN
  596.     END
  597.  
  598.  
  599.  
  600.     SUBROUTINE R8INRT
  601.  
  602. C------------------------------------------------------------------------------
  603. C
  604. C Function        : Fortran interfac eto the RAPPORT R0INRT.It's actions are
  605. C                           * Place the record to insert(obtained from the
  606. C                             message buffer) into the ipb .
  607. C                           * Call RAPPORT R0INRT.
  608. C
  609. C Input arguments : None.
  610. C
  611. C Output arguments: None.
  612. C
  613. C Common blocks   : The common message buffer WBUF accessed by
  614. C                   reference to the equivalent long word buffer .
  615. C
  616. C Called by       : Main.
  617. C
  618. C Calls           : PUTREC , RAPPORT : R0INRT
  619. C
  620. C Author          :                        (  /  /  )     Version 1.0
  621. C
  622. C Amendments      :                        (  /  /  )
  623. C
  624. C Notes           : 
  625. C
  626. C------------------------------------------------------------------------------
  627.  
  628.  
  629. C JFILE is the file number of the file to insert into.
  630.  
  631.     INTEGER JFILE
  632.  
  633. C JER is an indication of the success of R0INRT.
  634.  
  635.     INTEGER JER
  636.  
  637. C STRADD is the start address in the message buffer of the record to insert.
  638. C This is the first byte after the static parameters have been equivalenced.
  639.  
  640.     INTEGER STRADD
  641.  
  642.  
  643.     COMMON/MSGBUF/WBUF(10)
  644.     INTEGER*2 WBUF
  645.     INTEGER LWBUF(10)
  646.     EQUIVALENCE (WBUF,LWBUF)
  647.  
  648.     EQUIVALENCE (JER,LWBUF(2)) , (JFILE,LWBUF(3))
  649.  
  650.  
  651. C The record starts at long word 4 of the message buffer.This is because
  652. C the last static parameter is at long word 3 .
  653.  
  654.       STRADD=4
  655.  
  656. C Place the record into the ipb from the message buffer .
  657.  
  658.         CALL PUTREC(JFILE,STRADD)
  659.  
  660. C    WRITE(6,210)
  661. C 210    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0INRT'/)
  662.  
  663.     CALL R0INRT(JFILE,JER)
  664.  
  665. C    WRITE(6,211)
  666. C 211    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0INRT'/)
  667.  
  668.  
  669.       RETURN
  670.     END
  671.  
  672.  
  673.  
  674.  
  675.     SUBROUTINE R8UPDT
  676.  
  677. C------------------------------------------------------------------------------
  678. C
  679. C Function        : Fortran interface to the RAPPORT R0UPDT.It's actions are
  680. C                           * Place the record to UPDATYE(obtained from the
  681. C                             message buffer) into the ipb .
  682. C                           * Call RAPPORT R0UPDT.
  683. C
  684. C Input arguments : None.
  685. C
  686. C Output arguments: None.
  687. C
  688. C Common blocks   : The common message buffer WBUF.Accessed by reference to
  689. C                   the equivalent long word buffer .
  690. C
  691. C Called by       : Main.
  692. C
  693. C Calls           : PUTREC , RAPPORT : R0UPDT
  694. C
  695. C Author          :                        (  /  /  )     Version 1.0
  696. C
  697. C Amendments      :                        (  /  /  )
  698. C
  699. C Notes           : 
  700. C
  701. C------------------------------------------------------------------------------
  702.  
  703.  
  704. C JFILE is the file number of the file to update into.
  705.  
  706.     INTEGER JFILE
  707.  
  708. C JER is an indication of the success of R0UPDT.
  709.  
  710.     INTEGER JER
  711.  
  712. C STRADD is the start address in the message buffer of the record to update.
  713. C This is the first byte after the static parameters have been equivalenced.
  714.  
  715.     INTEGER STRADD
  716.  
  717.  
  718.     COMMON/MSGBUF/WBUF(10)
  719.     INTEGER*2 WBUF
  720.     INTEGER LWBUF(10)
  721.     EQUIVALENCE (WBUF,LWBUF)
  722.  
  723.     EQUIVALENCE (JER,LWBUF(2)) , (JFILE,LWBUF(3))
  724.  
  725.  
  726. C The record starts at long word 4 of the message buffer.This ia because
  727. C the last static parameter is at long word 3 .
  728.  
  729.       STRADD=4
  730.  
  731. C Put the record into the ipb from the message buffer
  732.  
  733.         CALL PUTREC(JFILE,STRADD)
  734.  
  735. C    WRITE(6,214)
  736. C 214    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0UPDT'/)
  737.  
  738.     CALL R0UPDT(JFILE,JER)
  739.  
  740. C    WRITE(6,215)
  741. C 215    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0UPDT'/)
  742.  
  743.  
  744.       RETURN
  745.     END
  746.  
  747.  
  748.  
  749.  
  750.     SUBROUTINE R8STOR
  751.  
  752. C------------------------------------------------------------------------------
  753. C
  754. C Function        : Fortran interface to the RAPPORT R0STOR.It's actions are
  755. C                           * Place the record to STORE(obtained from the
  756. C                             message buffer into the program buffers.
  757. C                           * Call RAPPORT R0STOR.
  758. C
  759. C Input arguments : None.
  760. C
  761. C Output arguments: None.
  762. C
  763. C Common blocks   : The common message buffer WBUF accessed by reference to the
  764. C                   equivalent long word buffer .
  765. C
  766. C Called by       : Main.
  767. C
  768. C Calls           : PUTREC , RAPPORT : R0STOR
  769. C
  770. C Author          :                        (  /  /  )     Version 1.0
  771. C
  772. C Amendments      :                        (  /  /  )
  773. C
  774. C Notes           : 
  775. C
  776. C------------------------------------------------------------------------------
  777.  
  778.  
  779. C JFILE is the file number of the file to to stote the record.
  780.  
  781.     INTEGER JFILE
  782.  
  783. C JER is an indication of the success of R0STOR.
  784.  
  785.     INTEGER JER
  786.  
  787. C STRADD is the start address in the message buffer of the record to STORE.
  788. C This is the first byte after the static parameters have been equivalenced.
  789.  
  790.     INTEGER STRADD
  791.  
  792.  
  793.     COMMON/MSGBUF/WBUF(10)
  794.     INTEGER*2 WBUF
  795.     INTEGER LWBUF(10)
  796.     EQUIVALENCE (WBUF,LWBUF)
  797.  
  798.     EQUIVALENCE (JER,LWBUF(2)) , (JFILE,LWBUF(3))
  799.  
  800.  
  801. C The record starts at long word 4 of the message buffer.This is because
  802. C the last static parameter is at long word 3 .
  803.  
  804.       STRADD=4
  805.  
  806. C Put the record into the ipb from the message buffer
  807.  
  808.         CALL PUTREC(JFILE,STRADD)
  809.  
  810. C    WRITE(6,217)
  811. C 217    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0STOR'/)
  812.  
  813.     CALL R0STOR(JFILE,JER)
  814.  
  815. C    WRITE(6,218)
  816. C 218    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0STOR'/)
  817.  
  818.  
  819.       RETURN
  820.     END
  821.  
  822.  
  823.     SUBROUTINE R8COND
  824.  
  825. C------------------------------------------------------------------------------
  826. C
  827. C Function        : Fortarn interface to the RAPPORT R0COND . R0COND places the
  828. C                   specified condition onto the  specified file . It's actions
  829. C                   are :- 
  830. C
  831. C                          * Set the number of elements to be found on the
  832. C                            right hand side of the condition .
  833. C                          * Place the right hand side into an array from the
  834. C                            message buffer .
  835. C                          * Calculate the size o fthe array .
  836. C                          * Call r0cond .
  837. C
  838. C Input arguments : None .
  839. C
  840. C Output arguments: None .
  841. C
  842. C Common blocks   : The common message buffer wbuf accessed by reference to
  843. C                   the equivalent long word buffer .
  844. C                   RCIFT/IFTYPE : Given a field number returns an index into
  845. C                                  FTYPE (The array of type information )
  846. C                   RCFT/FTYPE : The array of type information :-
  847. C                                  Element 1 - Base type of the field 
  848. C                                  Element 2 - Number of elements in the field
  849. C                                              0 => scalar .
  850. C                                  Element 3 - Number of characters in the 
  851. C                                              string if a character field .
  852. C                   RCFPT/IFPT : Given a file number returns the number of the
  853. C                                first field in that file .
  854. C 
  855. C
  856. C Called by       : MAIN .
  857. C
  858. C Calls           : RAPPORT : R0COND , R8CV01 , R8CV02 , R8CV03 .
  859. C
  860. C Author          : MDD                    (  /  /  )     Version 1.0
  861. C
  862. C Amendments      :                        (  /  /  )
  863. C
  864. C Notes           : 
  865. C
  866. C------------------------------------------------------------------------------
  867.  
  868.  
  869.  
  870.     COMMON/MSGBUF/WBUF(1)
  871.     INTEGER*2 WBUF
  872.  
  873.     INTEGER LWBUF(10)
  874.     EQUIVALENCE (LWBUF,WBUF)
  875.  
  876.  
  877. C JFILE is the number of the file to place the condition on .
  878.  
  879.     INTEGER JFILE
  880.  
  881. C JCOND is the current number of this condition in the overall condition set .
  882.  
  883.     INTEGER JCOND
  884.  
  885. C JFLD is the absolute number of the field that the condition is on .
  886.  
  887.     INTEGER JFLD
  888.  
  889. C JANAL is the any all switch . -1 => any element test -2 =>  all element
  890. C test 1=> subscript 0 otherwise .
  891.  
  892.     INTEGER JANAL
  893.  
  894. C If a particular array element is being testes then this is the subscript
  895. C of this element .
  896.  
  897.     INTEGER JSUBSC
  898.  
  899. C Thisa is the number of the relation i.e. EQUAL = 1 , .. UNEQUAL = 6 .
  900.  
  901.     INTEGER JREL
  902.  
  903. C Thios is the number of the conjunction with an added modifier to indicate
  904. C the level of the conjunction.A modifier of 10 is added for eachg level in the
  905. C Condition structure.
  906.  
  907.     INTEGER JCONJ
  908.  
  909.  
  910.     EQUIVALENCE (JFILE , LWBUF(2)) , (JCOND , LWBUF(3))
  911.     EQUIVALENCE (JFLD , LWBUF(4)) , (JANAL , LWBUF(5))
  912.     EQUIVALENCE (JSUBSC , LWBUF(6)) , (JREL , LWBUF(7))
  913.     EQUIVALENCE ( JCONJ , LWBUF(8))
  914.  
  915. C See Header .
  916.  
  917.     COMMON/RCFPT/IFPT(4)
  918.     INTEGER IFPT
  919.  
  920. C See Header .
  921.  
  922.     COMMON/RCFT/FTYPE(1)
  923.     INTEGER FTYPE
  924.  
  925. C See Header .
  926.  
  927.     COMMON/RCIFT/IFTYPE(1)
  928.     INTEGER IFTYPE
  929.  
  930. C TYPTR is the pointer into the FTYPE array for a particular field.
  931.  
  932.     INTEGER TYPTR
  933.  
  934. C ITYPE is the base type of the field ( 1 => integer , 2 => real ,
  935. C 3 => character ) .
  936.  
  937.     INTEGER ITYPE
  938.  
  939. C NELS is the number of elements in the field ( 0 => scalar ) .
  940.  
  941.     INTEGER NELS
  942.  
  943. C NCHARS is the number of characters in the string if the type is character .
  944.  
  945.     INTEGER NCHARS
  946.  
  947. C ARRINT is the array holding the condition right hand side in internal form .
  948.  
  949.     INTEGER ARRINT (50)
  950.  
  951. C JSIZ is the calculated size of arrint .
  952.  
  953.     INTEGER JSIZ
  954.  
  955. C STRADD is the position in the word buffer where the right hand side starts .
  956.  
  957.     INTEGER STRADD
  958.  
  959.  
  960. C    WRITE(6,55)
  961. C 55    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING SUBROUTINE R8COND'/)
  962.  
  963.  
  964.  
  965.  
  966.  
  967.     TYPTR=IFTYPE(JFLD)
  968.  
  969.     ITYPE=FTYPE(TYPTR)
  970.  
  971.  
  972. C If JANAL is not equal to 0 then the right hand side is a single element of
  973. C an array and so is scalar.Otherwise it is anormal field size .
  974.  
  975.     IF (JANAL.NE.0) THEN 
  976.                 NELS=0
  977.            ELSE NELS=FTYPE(TYPTR+1)
  978.         ENDIF
  979.  
  980.         IF(ITYPE.EQ.3) NCHARS=FTYPE(TYPTR+2)
  981.  
  982. C STRADD is the position in the long word buffer of the right hand side (9)
  983. C modifeid to give the corresponding position in the word buffer .
  984.  
  985.     STRADD=(9*2)-1        
  986.  
  987.  
  988. C Depending on the type of the field convert it to internal form .
  989.  
  990.     IF (ITYPE.EQ.1) CALL R8CV01(-1,STRADD,NELS,ARRINT)
  991.     IF (ITYPE.EQ.2) CALL R8CV02(-1,STRADD,NELS,ARRINT)
  992.     IF (ITYPE.EQ.3) CALL R8CV03(-1,STRADD,NELS,NCHARS,ARRINT)
  993.      
  994. C Calculate the size of the array holding the right hand side in internal
  995. C format . A character right hand side size is the number of elements * 
  996. C number of characters rounded up to the nearest long word .
  997.  
  998.     IF (NELS.EQ.0) NELS=1
  999.     IF (ITYPE.EQ.1) JSIZ=NELS
  1000.     IF (ITYPE.EQ.2) JSIZ=NELS
  1001.     IF (ITYPE.EQ.3) JSIZ=((NELS*NCHARS)+3)/4
  1002.  
  1003. C The field number must be made relative to the start of the particular file
  1004. C and not absolut (relative to the start of the ddf )
  1005.  
  1006.         JFLD=JFLD-IFPT(JFILE)+1
  1007.  
  1008.  
  1009.  
  1010.     CALL R0COND( JFILE , JCOND , JFLD , JANAL , JSUBSC , JREL 
  1011.      *               , JCONJ , ARRINT , JSIZ , .FALSE. )
  1012.  
  1013.  
  1014.  
  1015.     RETURN
  1016.     END
  1017.  
  1018.  
  1019.  
  1020.  
  1021.  
  1022.  
  1023.     SUBROUTINE R8FECH
  1024.  
  1025. C------------------------------------------------------------------------------
  1026. C
  1027. C Function        : Fortran interface to the RAPPORT R0FECH.It's actions are:-
  1028. C                           * Set the Level pointer ICT201 to the value of
  1029. C                             level gained from the message buffer.( this
  1030. C                             is now obsolete but is left in to avoid 
  1031. C                             complexities .
  1032. C                           * Call R0FECH.
  1033. C                           * Transfer the fetched record from the ipb to
  1034. C                             the message buffer.
  1035. C
  1036. C Input arguments : None.
  1037. C
  1038. C Output arguments: None.
  1039. C
  1040. C Common blocks   : The common message buffer WBUF reference by access to the
  1041. C                   equivalent long word buffer .
  1042. C                   The common area holding the level RCCTLP.
  1043. C
  1044. C Called by       : Main.
  1045. C
  1046. C Calls           : RAPPORT : R0FECH , GETREC
  1047. C
  1048. C Author          :                        (  /  /  )     Version 1.0
  1049. C
  1050. C Amendments      :                        (  /  /  )
  1051. C
  1052. C Notes           : 
  1053. C
  1054. C------------------------------------------------------------------------------
  1055.  
  1056.  
  1057. C JFILE is the number ofthe file to fetch the record from.
  1058.  
  1059.     INTEGER JFILE
  1060.  
  1061. C JCOUNT is an indicater to the last record that was fetched.
  1062.  
  1063.     INTEGER JCOUNT
  1064.  
  1065. C JGETT is the retrieval strategy that was set by the caller.If it is found by
  1066. C RAPPORT to be 0 then a strategy is chosen and returned for futute use.
  1067.  
  1068.     INTEGER JGETT
  1069.  
  1070. C NCOND is the number of conditions imposed upon this particular fetch.
  1071.  
  1072.     INTEGER NCOND
  1073.  
  1074. C LEVEL is the level in the search stack and the actual stack pointer
  1075. C ICT201 is made equal to this.This is not actually needed but is kept in
  1076. C to avoid the complexities of it's removal .
  1077.  
  1078.     INTEGER LEVEL
  1079.  
  1080. C STRADD is the address in the message buffer into which to start loading 
  1081. C the fetched record.It is in fact the first longword of the buffer after
  1082. C the equivalence of the static parameters.
  1083.  
  1084.     INTEGER STRADD
  1085.  
  1086.  
  1087.  
  1088.     COMMON/MSGBUF/WBUF(10)
  1089.     INTEGER*2 WBUF
  1090.     INTEGER LWBUF(10)
  1091.     EQUIVALENCE (WBUF,LWBUF)
  1092.         COMMON/RCCTLP/ICT201
  1093.  
  1094. C IC201 is the actual search loop stack pointer set equal to LEVEL.
  1095.  
  1096.     INTEGER ICT201
  1097.  
  1098.     EQUIVALENCE (JCOUNT,LWBUF(2)),(LEVEL,LWBUF(3))
  1099.     EQUIVALENCE (JFILE,LWBUF(4)),(JGETT,LWBUF(5))
  1100.     EQUIVALENCE (NCOND,LWBUF(6))
  1101.  
  1102.         COMMON/RCIPB/IPB(25)
  1103.         INTEGER IPB
  1104.         
  1105. C This is not needed but is kept in to avoid complexities .
  1106.  
  1107.         ICT201=LEVEL
  1108.  
  1109.  
  1110. C    WRITE(6,219)
  1111. C 219    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0FECH'/)
  1112.  
  1113.     CALL R0FECH(JFILE,JCOUNT,JGETT,NCOND)
  1114.  
  1115. C    WRITE(6,220)
  1116. C 220    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0FECH'/)
  1117.  
  1118.  
  1119. C STRADD is the start address in the message buffer to place the fetched record
  1120. C It is 7 because the last static parameter is at address 6 .
  1121.  
  1122.     STRADD=7
  1123.  
  1124. C Place the record into the message buffer from the ipb .
  1125.  
  1126.     CALL GETREC(JFILE,STRADD)
  1127.  
  1128.     RETURN 
  1129.     END
  1130.  
  1131.  
  1132.  
  1133.  
  1134.     SUBROUTINE R8DELT
  1135.  
  1136. C------------------------------------------------------------------------------
  1137. C
  1138. C Function        : Fortran interface to the RAPPORT R0DELT.
  1139. C
  1140. C Input arguments : None.
  1141. C
  1142. C Output arguments: None.
  1143. C
  1144. C Common blocks   : The common message buffer WBUF accessed by reference to
  1145. C                   the equivalent long word buffer .
  1146. C
  1147. C Called by       : Main
  1148. C
  1149. C Calls           : RAPPORT : R0DELT
  1150. C
  1151. C Author          :                        (  /  /  )     Version 1.0
  1152. C
  1153. C Amendments      :                        (  /  /  )
  1154. C
  1155. C Notes           : 
  1156. C
  1157. C------------------------------------------------------------------------------
  1158.  
  1159.  
  1160.  
  1161. C JFILE is the number of the file to delete from.
  1162.  
  1163.     INTEGER JFILE
  1164.  
  1165. C NCOND is the number of conditions applying to this particular deletion.
  1166.  
  1167.     INTEGER NCOND
  1168.  
  1169. C JCOUNT is returned as the number of records deleted by R0DELT or if an
  1170. C error has occurred it is signified by jcount.
  1171.  
  1172.     INTEGER JCOUNT
  1173.  
  1174.  
  1175.  
  1176.     COMMON/MSGBUF/WBUF(10)
  1177.     INTEGER*2 WBUF
  1178.     INTEGER LWBUF(10)
  1179.     EQUIVALENCE (WBUF,LWBUF)
  1180.  
  1181.       EQUIVALENCE (JCOUNT,LWBUF(2)),(JFILE,LWBUF(3))
  1182.     EQUIVALENCE (NCOND,LWBUF(4))
  1183.  
  1184.  
  1185. C    WRITE(6,223)
  1186. C 223    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0DELT'/)
  1187.     CALL R0DELT(JFILE,JCOUNT,NCOND)
  1188. C    WRITE(6,224)
  1189. C 224    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0DELT'/)
  1190.  
  1191.  
  1192.     RETURN
  1193.     END
  1194.  
  1195.  
  1196.  
  1197.  
  1198.  
  1199.  
  1200.     SUBROUTINE R8STKY
  1201.  
  1202. C------------------------------------------------------------------------------
  1203. C
  1204. C Function        : Fortran interface to the RAPPORT R0STKY.
  1205. C
  1206. C Input arguments : None.
  1207. C
  1208. C Output arguments: None.
  1209. C
  1210. C Common blocks   : The common message buffer WBUF accessed by reference to the
  1211. C                   equivalent long word buffer .
  1212. C                   RCFPT/IFPT : Given a file number returns the number of the
  1213. C                                first field in that fiule .
  1214. C  
  1215. C Called by       : Main.
  1216. C
  1217. C Calls           : R0STKY
  1218. C
  1219. C Author          :                        (  /  /  )     Version 1.0
  1220. C
  1221. C Amendments      :                        (  /  /  )
  1222. C
  1223. C Notes           : 
  1224. C
  1225. C------------------------------------------------------------------------------
  1226.  
  1227.  
  1228.  
  1229. C JFILE is the numebr of the file that the sort keys are for.
  1230.  
  1231.     INTEGER JFILE
  1232.  
  1233. C NSKEY is the number of keys in the sort key array.
  1234.  
  1235.     INTEGER NSKEY
  1236.  
  1237. C JSOKEY is the array of sort keys.It is dimensioned with the dummy parameter
  1238. C one as we do not at compile time know it's size.
  1239.  
  1240.     INTEGER JSOKEY(1)
  1241.  
  1242. C JTYPE is an indicater of the type of retrieval that will be performed on
  1243. C the finally ordered file.0  => a normal retrieval and 1 => a unique
  1244. C retrieval.
  1245.  
  1246.     INTEGER JTYPE
  1247.  
  1248. C SKCNT is a count used when modifying the sort keys to be reative to the 
  1249. C start of the file .
  1250.  
  1251.     INTEGER SKCNT
  1252.  
  1253. C See Header .
  1254.  
  1255.     COMMON/RCFPT/IFPT(3)
  1256.     INTEGER IFPT
  1257.  
  1258.  
  1259.     COMMON/MSGBUF/WBUF(10)
  1260.     INTEGER*2 WBUF
  1261.     INTEGER LWBUF(10)
  1262.     EQUIVALENCE (WBUF,LWBUF)
  1263.  
  1264.  
  1265.     EQUIVALENCE (JFILE,LWBUF(2)),(JTYPE,LWBUF(3))
  1266.     EQUIVALENCE (NSKEY,LWBUF(4)),(JSOKEY(1),LWBUF(5))
  1267.  
  1268.  
  1269. C The Sort keys that are obtained from the message buffer are in absolute
  1270. C form i.e. relative to the first field of the first file in the ddf but are 
  1271. C required in relative form ( to the first field of this file ) .
  1272.  
  1273.     DO SKCNT=1,NSKEY
  1274.            IF (JSOKEY(SKCNT).GT.0) 
  1275.      *        JSOKEY(SKCNT)=JSOKEY(SKCNT)-IFPT(JFILE)+1
  1276.            IF (JSOKEY(SKCNT).LT.0) 
  1277.      *        JSOKEY(SKCNT)=JSOKEY(SKCNT)+IFPT(JFILE)-1
  1278.         ENDDO
  1279.  
  1280.  
  1281.  
  1282. C    WRITE(6,227)
  1283. C 227    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0STKY'/)
  1284.  
  1285.     CALL R0STKY(JFILE,JSOKEY,NSKEY,JTYPE)
  1286.  
  1287. C    WRITE(6,228)
  1288. C 228    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0STKY'/)
  1289.  
  1290.     RETURN
  1291.     END
  1292.  
  1293.  
  1294.  
  1295.  
  1296.     SUBROUTINE R8HOLD
  1297.  
  1298. C------------------------------------------------------------------------------
  1299. C
  1300. C Function        : Fortran interface to the RAPPORT R0HOLD.
  1301. C
  1302. C Input arguments : None.
  1303. C
  1304. C Output arguments: None.
  1305. C
  1306. C Common blocks   : The common message buffer WBUF accessed by reference to the
  1307. C                   equivalent long word buffer .
  1308. C
  1309. C Called by       : Main
  1310. C
  1311. C Calls           : RAPPORT : R0HOLD
  1312. C
  1313. C Author          :                        (  /  /  )     Version 1.0
  1314. C
  1315. C Amendments      :                        (  /  /  )
  1316. C
  1317. C Notes           : 
  1318. C
  1319. C------------------------------------------------------------------------------
  1320.  
  1321.  
  1322.  
  1323. C JFILE is the number of the file on which to perform the HOLD.
  1324.  
  1325.     INTEGER JFILE
  1326.  
  1327. C NCOND is the number of conditions preiously set .
  1328.  
  1329.     INTEGER NCOND
  1330.  
  1331. C NREC IS RETURNED AS THE NUMBER OF RECORDS IN THE HOLD
  1332.  
  1333.     INTEGER NREC
  1334.  
  1335.  
  1336.     COMMON/MSGBUF/WBUF(10)
  1337.     INTEGER*2 WBUF
  1338.     INTEGER LWBUF(10)
  1339.     EQUIVALENCE (WBUF,LWBUF)
  1340.  
  1341.     EQUIVALENCE (JFILE,LWBUF(2)),(NCOND,LWBUF(3))
  1342.     EQUIVALENCE (NREC,LWBUF(4))
  1343.  
  1344.  
  1345.  
  1346. C    WRITE(6,229)
  1347. C 229    FORMAT(1X,'  %USERCALL-TRACEMSG-ENETRING RAPPORT R0HOLD'/)
  1348.  
  1349.     CALL R0HOLD(JFILE,NCOND,NREC)
  1350.  
  1351. C    WRITE(6,230)
  1352. C 230    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0HOLD'/)
  1353.  
  1354.  
  1355.     RETURN
  1356.     END
  1357.  
  1358.  
  1359.  
  1360.     SUBROUTINE R8ENRV
  1361.  
  1362. C------------------------------------------------------------------------------
  1363. C
  1364. C Function        : Fortarn interface to the RAPPORT R0ENRV.
  1365. C
  1366. C Input arguments : None.
  1367. C
  1368. C Output arguments: None.
  1369. C
  1370. C Common blocks   : The common mesage buffer WBUF accessed by refernce to the
  1371. C                   equivalent long word buffer .
  1372. C
  1373. C Called by       : Main.
  1374. C
  1375. C Calls           : RAPPORT : R0ENRV
  1376. C
  1377. C Author          :                        (  /  /  )     Version 1.0
  1378. C
  1379. C Amendments      :                        (  /  /  )
  1380. C
  1381. C Notes           : 
  1382. C
  1383. C------------------------------------------------------------------------------
  1384.  
  1385.  
  1386.  
  1387.  
  1388. C JCOUNT is a pointer to the last record in the file to be retrieved.
  1389.  
  1390.     INTEGER JCOUNT
  1391.  
  1392. C JER is an indication of the success of R0ENRV
  1393.  
  1394.     INTEGER JER
  1395.  
  1396.  
  1397.  
  1398.     COMMON/MSGBUF/WBUF(10)
  1399.     INTEGER*2 WBUF
  1400.     INTEGER LWBUF(10)
  1401.     EQUIVALENCE (WBUF,LWBUF)
  1402.  
  1403.     EQUIVALENCE (JER,LWBUF(2)),(JCOUNT,LWBUF(3))
  1404.  
  1405.  
  1406. C    WRITE(6,231)
  1407. C 231    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0ENRV'/)
  1408.  
  1409.     CALL R0ENRV(JCOUNT,JER)
  1410.  
  1411. C    WRITE(6,232)
  1412. C 232    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0ENRV'/)
  1413.  
  1414.  
  1415.     RETURN
  1416.     END
  1417.  
  1418.  
  1419.  
  1420.  
  1421.     
  1422.     SUBROUTINE R8RTRV
  1423.  
  1424. C------------------------------------------------------------------------------
  1425. C
  1426. C Function        : Fortran interface to the RAPPORT R0RTRV.This gets a record
  1427. C                   from a file that is sorted . 
  1428. C
  1429. C Input arguments : None .
  1430. C
  1431. C Output arguments: None .
  1432. C
  1433. C Common blocks   : The common message buffer WBUF referenced by accessing 
  1434. C                   the equivalent long word buffer .
  1435. C
  1436. C Called by       : MAIN .
  1437. C
  1438. C Calls           : RAPPORT : R0RTRV ; GETREC .
  1439. C
  1440. C Author          :                        (  /  /  )     Version 1.0
  1441. C
  1442. C Amendments      :                        (  /  /  )
  1443. C
  1444. C Notes           : 
  1445. C
  1446. C------------------------------------------------------------------------------
  1447.  
  1448. C JFILE is the number of the file that was sorted .
  1449.  
  1450.         INTEGER JFILE
  1451.  
  1452.  
  1453. C JCOUNT is the count variable inicating the last record fetched.
  1454.  
  1455.     INTEGER JCOUNT
  1456.  
  1457. C STRADD is the start address in the message buffer to return the record to
  1458.  
  1459.     INTEGER STRADD
  1460.  
  1461.  
  1462.     COMMON/MSGBUF/WBUF(5)
  1463.     INTEGER*2 WBUF
  1464.  
  1465.     INTEGER LWBUF(4)
  1466.     EQUIVALENCE (LWBUF,WBUF)
  1467.  
  1468.     EQUIVALENCE (LWBUF(2),JCOUNT)
  1469.         EQUIVALENCE (LWBUF(3),JFILE)
  1470.  
  1471. C    WRITE(6,482)
  1472. C 482    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING SUBROUTINE R8RTRV'/)
  1473.  
  1474. C     WRITE(6,483)
  1475. C 483    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0RTRV'/)
  1476.  
  1477.     CALL R0RTRV ( JCOUNT )
  1478.  
  1479. C    WRITE(6,484)
  1480. C 484    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0RTRV'/)
  1481.  
  1482. C The address in the message buffer to start placing the record in is
  1483. C long word 4 as thalast static parameter is at long word 3 .
  1484.  
  1485.     STRADD = 4
  1486.  
  1487. C Place the record in the message buffer from the ipb .
  1488.  
  1489.     CALL GETREC ( JFILE , STRADD )
  1490.  
  1491. C    WRITE(6,485)
  1492. C 485    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING SUBROUTINE R8RTRV'/)
  1493.  
  1494.     RETURN
  1495.     END
  1496.  
  1497.  
  1498.  
  1499.  
  1500.  
  1501.     SUBROUTINE R8CLFI
  1502.  
  1503. C------------------------------------------------------------------------------
  1504. C
  1505. C Function        : Fortran interface to the RAPPORT : R0CLFI
  1506. C
  1507. C Input arguments : None.
  1508. C
  1509. C Output arguments: None.
  1510. C
  1511. C Common blocks   : The common message buffer WBUF accessed by refernce to the
  1512. C                   equivalent long word buffer .
  1513. C
  1514. C Called by       : Main.
  1515. C
  1516. C Calls           : RAPPORT : R0CLFI
  1517. C
  1518. C Author          :                        (  /  /  )     Version 1.0
  1519. C
  1520. C Amendments      :                        (  /  /  )
  1521. C
  1522. C Notes           : 
  1523. C
  1524. C------------------------------------------------------------------------------
  1525.  
  1526.  
  1527.  
  1528. C JFILE is the number of the file to clear.
  1529.  
  1530.     INTEGER JFILE
  1531.  
  1532. C JER is an indication of the success of R0CLFI.
  1533.  
  1534.      INTEGER JER
  1535.  
  1536.  
  1537.  
  1538.     COMMON/MSGBUF/WBUF(10)
  1539.     INTEGER*2 WBUF
  1540.     INTEGER LWBUF(10)
  1541.     EQUIVALENCE (WBUF,LWBUF)
  1542.  
  1543.     EQUIVALENCE (JER,LWBUF(2)),(JFILE,LWBUF(3))
  1544.  
  1545.  
  1546. C    WRITE(6,235)
  1547. C 235    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0CLFI'/)
  1548.     CALL R0CLFI(JFILE,JER)
  1549. C    WRITE(6,236)
  1550. C 236    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0CLFI'/)
  1551.  
  1552.  
  1553.     RETURN
  1554.     END
  1555.  
  1556.  
  1557.     SUBROUTINE R8LOCK
  1558.  
  1559. C------------------------------------------------------------------------------
  1560. C
  1561. C Function        : Fortran interface to the RAPPORT R0LOCK.
  1562. C
  1563. C Input arguments : None.
  1564. C
  1565. C Output arguments: None.
  1566. C
  1567. C Common blocks   : The common message buffer WBUF refernced by equivalence to
  1568. C                   a long word buffer .
  1569. C
  1570. C Called by       : Main.
  1571. C
  1572. C Calls           : RAPPORT : R0LOCK
  1573. C
  1574. C Author          :                        (  /  /  )     Version 1.0
  1575. C
  1576. C Amendments      :                        (  /  /  )
  1577. C
  1578. C Notes           : 
  1579. C
  1580. C------------------------------------------------------------------------------
  1581.  
  1582.  
  1583.  
  1584. C JFILE is the number o fthe file to lock
  1585.  
  1586.     INTEGER JFILE
  1587.  
  1588. C JREWO is the switch indivating how to lock the file 
  1589.  
  1590.     INTEGER JREWO
  1591.  
  1592. C JER is an indication of the success of R0LOCK
  1593.  
  1594.     INTEGER JER
  1595.  
  1596.  
  1597.  
  1598.     COMMON/MSGBUF/WBUF(10)
  1599.     INTEGER*2 WBUF
  1600.     INTEGER LWBUF(10)
  1601.     EQUIVALENCE (WBUF,LWBUF)
  1602.  
  1603.     EQUIVALENCE (JER,LWBUF(2)),(JFILE,LWBUF(3))
  1604.     EQUIVALENCE (JREWO,LWBUF(4))
  1605.  
  1606. c    write(6,444)jfile,jrewo
  1607. c444    format(1x,'file , rw'i,i/)
  1608.  
  1609.  
  1610. c    WRITE(6,237)
  1611. c237    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING RAPPORT R0LOCK'/)
  1612.  
  1613.     CALL R0LOCK(JFILE,JREWO,JER)
  1614.  
  1615. c    WRITE(6,238)
  1616. c238    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING RAPPORT R0LOCK'/)
  1617.  
  1618.  
  1619.     RETURN 
  1620.     END
  1621.  
  1622.  
  1623.  
  1624.  
  1625.     SUBROUTINE PUTREC(JFILE,STRADD)
  1626.  
  1627. C------------------------------------------------------------------------------
  1628. C
  1629. C Function        : Moves a record , field by field , from the message buffer
  1630. C                   to the program buffers.An outline algorithm for this is:-
  1631. C                          * Get the number of fields in the record
  1632. C                          * LOOP for the number of fields
  1633. C                                 - find the type of the field
  1634. C                                 - depending on the type call a conversion
  1635. C                                   routine.
  1636. C                                   1.) R8CV01 (integer conversion)
  1637. C                                   2.) R8CV02 (real conversion)
  1638. C                                   3.) R8CVo3 (character conversion)
  1639. C                          * end LOOP
  1640. C
  1641. C Input arguments : JFILE:- The number of the file of the record.Used to
  1642. C                           extract information about the number of fields
  1643. C                           in the record.
  1644. C                   STRADD:-the start address in the message buffer to get
  1645. C                           the record from.
  1646. C
  1647. C Output arguments: None.
  1648. C
  1649. C Common blocks   : RCFDS/NOFDS : information about the number of fields in a
  1650. C                                 given file.
  1651. C                   RCIFT/IFTYPE : given a field number returns a pointer into
  1652. C                                  the type description array tp get type
  1653. C                                  information for that particular field.
  1654. C                   RCFT/FTYPE : holds the array of type information.The 
  1655. C                                structure of this array is -
  1656. C                                 Element 1 - type
  1657. C                                 Element 2 - number of elemnts in field
  1658. C                                 Element 3 - if character then number of 
  1659. C                                             chars in string.
  1660. C                   RCFPT/IFPT : contains an array giving for every file the 
  1661. C                                number of the first field.
  1662. C                   RCJWT/JWTEST : } These are to locate the positiuon of a
  1663. C                   RCIF/IFTEST :  } particular field in the ipb .
  1664. C                   RCIPB/IPB : The ipb .
  1665. C                   RCIIPB/IIPB : The index into the ipb for a given file .
  1666. C                   RCPPRM/ : Various rapport parameters .
  1667. C
  1668. C Called by       : R8INRT , R8UPDT , R8STOR
  1669. C
  1670. C Calls           : R8cv01 , R8CV02 , R8cv03
  1671. C
  1672. C Author          :                        (  /  /  )     Version 1.0
  1673. C
  1674. C Amendments      :                        (  /  /  )
  1675. C
  1676. C Notes           : 
  1677. C
  1678. C------------------------------------------------------------------------------
  1679.  
  1680.  
  1681.  
  1682. C JFILE is the number of the file concerned
  1683.  
  1684.     INTEGER JFILE
  1685.  
  1686. C STRADD is the start address in the message buffer to transfer the record
  1687. C from.
  1688.  
  1689.     INTEGER STRADD
  1690.  
  1691. C TOTFDS is the number of fields in the file.
  1692.  
  1693.     INTEGER TOTFDS
  1694.  
  1695. C FLDNO is a count variable indicating the field to transfer.
  1696.  
  1697.     INTEGER FLDNO
  1698.  
  1699. C FSTFLD is the number of the first field in the file
  1700.  
  1701.     INTEGER FSTFLD
  1702.  
  1703. C LSTFLD is the number of the last field in the file.
  1704.  
  1705.     INTEGER LSTFLD
  1706.  
  1707. C TYPE is information about the base type of the field , NELS is the number
  1708. C of elements in the filed and NCHARS is,if the field is a character field
  1709. C the number of characters in the string.
  1710.  
  1711.     INTEGER ITYPE,NELS,NCHARS
  1712.  
  1713. C BUFADD is the current position in the message buffer in words.The inputed
  1714. C address is in long words so BUFADD:=STRADD*2-1.
  1715.  
  1716.     INTEGER BUFADD
  1717.  
  1718. C TYPTR is a pointer into the type array for a particular fiel;d
  1719.  
  1720.     INTEGER TYPTR
  1721.  
  1722. C ARRINT  is the field value in internal form returned by the R*CV'S as the
  1723. C conversion of the ADA field value
  1724.  
  1725.     INTEGER ARRINT(50)
  1726.  
  1727. C RFLDNO is the number of the field relatve to the start of the file.
  1728.  
  1729.     INTEGER RFLDNO
  1730.  
  1731. C IFLD
  1732.  
  1733.     INTEGER IFLD
  1734.  
  1735.  
  1736. C See Header .
  1737.  
  1738.     COMMON/RCFDS/NOFDS(1)
  1739.     INTEGER NOFDS
  1740.  
  1741. C See Header .
  1742.  
  1743.     COMMON/RCFPT/IFPT(1)
  1744.     INTEGER IFPT
  1745.  
  1746. C See Header .
  1747.  
  1748.     COMMON/RCFT/FTYPE(1)
  1749.     INTEGER FTYPE
  1750.  
  1751. C See Header .
  1752.  
  1753.     COMMON/RCIFT/IFTYPE(1)
  1754.     INTEGER IFTYPE
  1755.  
  1756. C See Header .
  1757.  
  1758.     COMMON/RCJWT/JWTEST(1)
  1759.     INTEGER JWTEST
  1760.  
  1761. C See Header .
  1762.  
  1763.     COMMON/RCIF/IFTEST(1)
  1764.     INTEGER IFTEST
  1765.  
  1766. C See Header
  1767.  
  1768.     COMMON/RCPPRM/DUMM1(20),MWOFBF,DUMM2(14),MWOIPB
  1769.     INTEGER DUMM1,DUMM2,MWOFBF,MWOIPB
  1770.  
  1771. C See Header .
  1772.  
  1773.     COMMON/RCIPB/IPB(300)
  1774.     INTEGER IPB
  1775.  
  1776. C See Header .
  1777.  
  1778.     COMMON/RCIIPB/IIPB(1)
  1779.     INTEGER IIPB
  1780.  
  1781.  
  1782. C LER is the error returned from RUCPEI
  1783.  
  1784.     LOGICAL LER
  1785.  
  1786.  
  1787. C    WRITE(6,208)
  1788. C 208    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING ROUTINE PUTREC'/)
  1789.  
  1790.  
  1791. C Set up the parameters required .
  1792. C TOTFDS the number of fields in the file .
  1793. C FSTFLD is the number of the first field in the file .
  1794. C LSTFLD is the number of the last field in the file.
  1795. C BUFADD is the address in the message buffer to get the record in words .
  1796.  
  1797.  
  1798.     TOTFDS=NOFDS(JFILE)
  1799.     FSTFLD=IFPT(JFILE)
  1800.     LSTFLD=FSTFLD+TOTFDS-1
  1801.     BUFADD=(STRADD*2)-1
  1802.  
  1803.  
  1804.  
  1805.  
  1806. C LOOP to transfer all the fields to the ipb .
  1807.  
  1808.     DO FLDNO=FSTFLD,LSTFLD
  1809.  
  1810.  
  1811. C Set up the field dependant variables .
  1812. C TYPTR is the index into ftype for the field .
  1813. C ITYPE is the base type of the field .
  1814. C NELS is the number of elements of this base type in the field .
  1815. C NCHARS if the base type is character is the number of elements in tyhe string
  1816.  
  1817.        TYPTR=IFTYPE(FLDNO)
  1818.        ITYPE=FTYPE(TYPTR)
  1819.        NELS=FTYPE(TYPTR+1)
  1820.        IF (ITYPE.EQ.3) NCHARS=FTYPE(TYPTR+2)
  1821.  
  1822. C Get the field from the message buffer into arrint and convert into
  1823. C internal format . BUFADD is returned as the address in the word byffer of
  1824. C the next field .
  1825.  
  1826.        IF (ITYPE.EQ.1) CALL R8CV01(-1,BUFADD,NELS,ARRINT)
  1827.        IF (ITYPE.EQ.2) CALL R8CV02(-1,BUFADD,NELS,ARRINT)
  1828.        IF (ITYPE.EQ.3) CALL R8CV03(-1,BUFADD,NELS,NCHARS,
  1829.      *                                 ARRINT)
  1830.  
  1831.  
  1832.  
  1833.  
  1834. C RFLDNO is the number of the field relative to the start of the file .
  1835. C IFLD is the index into jwtest for that field .
  1836.  
  1837.             RFLDNO=FLDNO-FSTFLD
  1838.        IFLD=IFTEST(JFILE)+RFLDNO
  1839.  
  1840.  
  1841. C Transfer the field in internal format from arrint to the ipb . The format
  1842. C of the call is :-
  1843. C
  1844. C       RUCPEI ( Sense , TypeInformation , StartOfTypeInformation ,
  1845. C                EndOfTypeInformation , ipb , SizeOfIpb ,
  1846. C                WhereInIpbToStartLoading , 0 => Transfer all elements ,
  1847. C                arrint , SizeOfArrint , WhereToTRansferFromInArrint , LER )
  1848. C
  1849. C Sense = -1  =>  ARRINT -> IPB
  1850. C Sense = 1  =>  IPB -> ARRINT
  1851. C
  1852.  
  1853.  
  1854.  
  1855.        CALL RUCPEI(-1,FTYPE,IFTYPE(FLDNO),IFTYPE(FLDNO+1)-1,
  1856.      *                 IPB,MWOIPB,IIPB(JFILE)+JWTEST(IFLD)-1,0,
  1857.      *                 ARRINT,50,1,LER)
  1858.  
  1859.  
  1860.  
  1861.     ENDDO
  1862.  
  1863.  
  1864.  
  1865.  
  1866. C    WRITE(6,209)
  1867. C 209    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING ROUTINE PUTREC'/)
  1868.  
  1869.  
  1870.  
  1871.  
  1872.  
  1873.     RETURN
  1874.     END
  1875.  
  1876.  
  1877.  
  1878.  
  1879.  
  1880.     SUBROUTINE GETREC(JFILE,STRADD)
  1881.  
  1882. C------------------------------------------------------------------------------
  1883. C
  1884. C Function        : Moves a record , field by field , from the message buffer
  1885. C                   to the program buffers.An outline algorithm for this is:-
  1886. C                          * Get the number of fields in the record
  1887. C                          * LOOP for the number of fields
  1888. C                                 - find the type of the field
  1889. C                                 - depending on the type call a conversion
  1890. C                                   routine.
  1891. C                                   1.) R8CV01 (integer conversion)
  1892. C                                   2.) R8CV02 (real conversion)
  1893. C                                   3.) R8CVo3 (character conversion)
  1894. C                          * end LOOP
  1895. C
  1896. C Input arguments : JFILE:- The number of the file of the record.Used to
  1897. C                           extract information about the number of fields
  1898. C                           in the record.
  1899. C                   STRADD:-the start address in the message buffer to get
  1900. C                           the record from.
  1901. C
  1902. C Output arguments: None.
  1903. C Common blocks   : RCFDS/NOFDS : information about the number of fields in a
  1904. C                                 given file.
  1905. C                   RCIFT/IFTYPE : given a field number returns a pointer into
  1906. C                                  the type description array tp get type
  1907. C                                  information for that particular field.
  1908. C                   RCFT/FTYPE : holds the array of type information.The 
  1909. C                                structure of this array is -
  1910. C                                 Element 1 - type
  1911. C                                 Element 2 - number of elemnts in field
  1912. C                                 Element 3 - if character then number of 
  1913. C                                             chars in string.
  1914. C                   RCFPT/IFPT : contains an array giving for every file the 
  1915. C                                number of the first field.
  1916. C                   RCJWT/JWTEST : } These are to locate the positiuon of a
  1917. C                   RCIF/IFTEST :  } particular field in the ipb .
  1918. C                   RCIPB/IPB : The ipb .
  1919. C                   RCIIPB/IIPB : The index into the ipb for a given file .
  1920. C                   RCPPRM/ : Various rapport parameters .
  1921. C
  1922. C Called by       : R8INRT , R8UPDT , R8STOR
  1923. C
  1924. C Calls           : R8cv01 , R8CV02 , R8cv03
  1925. C
  1926. C Author          :                        (  /  /  )     Version 1.0
  1927. C
  1928. C Amendments      :                        (  /  /  )
  1929. C
  1930. C Notes           : 
  1931. C
  1932. C------------------------------------------------------------------------------
  1933.  
  1934.  
  1935.  
  1936. C JFILE is the number of the file concerned
  1937.  
  1938.     INTEGER JFILE
  1939.  
  1940. C STRADD is the start address in the message buffer to transfer the record
  1941. C from.
  1942.  
  1943.     INTEGER STRADD
  1944.  
  1945. C TOTFDS is the number of fields in the file.
  1946.  
  1947.     INTEGER TOTFDS
  1948.  
  1949. C FLDNO is a count variable indicating the field to transfer.
  1950.  
  1951.     INTEGER FLDNO
  1952.  
  1953. C FSTFLD is the number of the first field in the file
  1954.  
  1955.     INTEGER FSTFLD
  1956.  
  1957. C LSTFLD is the number of the last field in the file.
  1958.  
  1959.     INTEGER LSTFLD
  1960.  
  1961. C TYPE is information about the base type of the field , NELS is the number
  1962. C of elements in the filed and NCHARS is,if the field is a character field
  1963. C the number of characters in the string.
  1964.  
  1965.     INTEGER ITYPE,NELS,NCHARS
  1966.  
  1967. C BUFADD is the current position in the message buffer in words.The inputed
  1968. C address is in long words so BUFADD:=STRADD*2-1.
  1969.  
  1970.     INTEGER BUFADD
  1971.  
  1972. C TYPTR is a pointer into the type array for a particular fiel;d
  1973.  
  1974.     INTEGER TYPTR
  1975.  
  1976. C ARRINT  is the field value in internal form returned by the R*CV'S as the
  1977. C conversion of the ADA field value
  1978.  
  1979.     INTEGER ARRINT(50)
  1980.  
  1981. C RFLDNO is the number of the field relatve to the start of eth file.
  1982.  
  1983.     INTEGER RFLDNO
  1984.  
  1985. C IFLD
  1986.  
  1987.     INTEGER IFLD
  1988.  
  1989.  
  1990. C See Header .
  1991.  
  1992.     COMMON/RCFDS/NOFDS(1)
  1993.     INTEGER NOFDS
  1994.  
  1995. C See Header .
  1996.  
  1997.     COMMON/RCFPT/IFPT(1)
  1998.     INTEGER IFPT
  1999.  
  2000. C See Header .
  2001.  
  2002.     COMMON/RCFT/FTYPE(1)
  2003.     INTEGER FTYPE
  2004.  
  2005. C See Header .
  2006.  
  2007.     COMMON/RCIFT/IFTYPE(1)
  2008.     INTEGER IFTYPE
  2009.  
  2010. C See Header .
  2011.  
  2012.     COMMON/RCJWT/JWTEST(1)
  2013.     INTEGER JWTEST
  2014.  
  2015. C See Header .
  2016.  
  2017.     COMMON/RCIF/IFTEST(1)
  2018.     INTEGER IFTEST
  2019.  
  2020. C See Header .
  2021.  
  2022.     COMMON/RCPPRM/DUMM1(20),MWOFBF,DUMM2(14),MWOIPB
  2023.     INTEGER DUMM1,DUMM2,MWOFBF,MWOIPB
  2024.  
  2025. C See Header .
  2026.  
  2027.     COMMON/RCIPB/IPB(300)
  2028.     INTEGER IPB
  2029.  
  2030. C See Header .
  2031.  
  2032.     COMMON/RCIIPB/IIPB(1)
  2033.     INTEGER IIPB
  2034.  
  2035. C LER is the error returned from rucpei .
  2036.  
  2037.     LOGICAL LER
  2038.  
  2039.  
  2040. C    WRITE(6,769)
  2041. C 769    FORMAT(1X,'  %USERCALL-TRACEMSG-ENTERING ROUTINE GETREC'/)
  2042.  
  2043.  
  2044. C Set up the parameters required .
  2045. C TOTFDS the number of fields in the file .
  2046. C FSTFLD is the number of the first field in the file .
  2047. C LSTFLD is the number of the last field in the file.
  2048. C BUFADD is the address in the message buffer to put the record in words .
  2049.  
  2050.     TOTFDS=NOFDS(JFILE)
  2051.     FSTFLD=IFPT(JFILE)
  2052.     LSTFLD=FSTFLD+TOTFDS-1
  2053.     BUFADD=(STRADD*2)-1
  2054.  
  2055.  
  2056. C LOOP for the number of fileds .
  2057.  
  2058.     DO FLDNO=FSTFLD,LSTFLD
  2059.  
  2060.  
  2061.  
  2062.  
  2063.  
  2064.  
  2065. C RFLDNO is the number of the field relative to the start of the file .
  2066. C IFLD is the index into jwtest for that field .
  2067.  
  2068.             RFLDNO=FLDNO-FSTFLD
  2069.        IFLD=IFTEST(JFILE)+RFLDNO
  2070.  
  2071.  
  2072. C Transfer the field in internal format from arrint to the ipb . The format
  2073. C of the call is :-
  2074. C
  2075. C       RUCPEI ( Sense , TypeInformation , StartOfTypeInformation ,
  2076. C                EndOfTypeInformation , ipb , SizeOfIpb ,
  2077. C                WhereInIpbToStartLoading , 0 => Transfer all elements ,
  2078. C                arrint , SizeOfArrint , WhereToTRansferFromInArrint , LER )
  2079. C
  2080. C Sense = -1  =>  ARRINT -> IPB
  2081. C Sense = 1  =>  IPB -> ARRINT
  2082. C
  2083.  
  2084.  
  2085.  
  2086.        CALL RUCPEI(1,FTYPE,IFTYPE(FLDNO),IFTYPE(FLDNO+1)-1,
  2087.      *                 IPB,MWOIPB,IIPB(JFILE)+JWTEST(IFLD)-1,0,
  2088.      *                 ARRINT,50,1,LER)
  2089.  
  2090.  
  2091. C Set up the field dependant variables .
  2092. C TYPTR is the index into ftype for the field .
  2093. C ITYPE is the base type of the field .
  2094. C NELS is the number of elements of this base type in the field .
  2095. C NCHARS if the base type is character is the number of elements in tyhe string
  2096.  
  2097.  
  2098.        TYPTR=IFTYPE(FLDNO)
  2099.        ITYPE=FTYPE(TYPTR)
  2100.        NELS=FTYPE(TYPTR+1)
  2101.        IF (ITYPE.EQ.3) NCHARS=FTYPE(TYPTR+2)
  2102.  
  2103.        IF (ITYPE.EQ.1) CALL R8CV01(1,BUFADD,NELS,ARRINT)
  2104.        IF (ITYPE.EQ.2) CALL R8CV02(1,BUFADD,NELS,ARRINT)
  2105.        IF (ITYPE.EQ.3) CALL R8CV03(1,BUFADD,NELS,NCHARS,
  2106.      *                                 ARRINT)
  2107.  
  2108.  
  2109.  
  2110.  
  2111.  
  2112.     ENDDO
  2113.  
  2114.  
  2115.  
  2116.  
  2117. C    WRITE(6,770)
  2118. C 770    FORMAT(1X,'  %USERCALL-TRACEMSG-LEAVING ROUTINE getREC'/)
  2119.  
  2120.  
  2121.  
  2122.  
  2123.  
  2124.     RETURN
  2125.     END
  2126.  
  2127.  
  2128.  
  2129.  
  2130.  
  2131.     SUBROUTINE R8CV02(SENSE , BUFADD , NELS , ARRINT)
  2132.  
  2133. C------------------------------------------------------------------------------
  2134. C
  2135. C Function        : Get an real field from the message buffer starting at 
  2136. C                   address BUFADD convert to internal format and place
  2137. C                   in output array arrint . Note that npo conversion is infact
  2138. C                   needed and the process is a straight copy .
  2139. C                   Or from the array arrint into the message buffer                   
  2140. C
  2141. C Input arguments : SENSE = -1 => Move field Message buffer -> Arrint
  2142. C                   SENSE = 1 => Move field arrint -> message buffer .
  2143. C                   BUFADD : the address in the word message buffer .        
  2144. C                   NELS : the number of elements to transfer .
  2145. C
  2146. C Output arguments: BUFADD
  2147. C                   ARRINT : Output is sense = -1 and moving into arrint .
  2148. C
  2149. C Common blocks   : The common message buffer wbuf .
  2150. C
  2151. C Called by       : PUTREC , GETREC , R8COND .
  2152. C
  2153. C Calls           : None .
  2154. C
  2155. C Author          :                        (  /  /  )     Version 1.0
  2156. C
  2157. C Amendments      :                        (  /  /  )
  2158. C
  2159. C Notes           : 
  2160. C
  2161. C------------------------------------------------------------------------------
  2162.  
  2163.  
  2164.  
  2165. C SENSE decides in which direction the transferance is to be (see header)
  2166.  
  2167.     INTEGER SENSE
  2168.  
  2169. C BUFADD is the address in the message buffer.
  2170.  
  2171.     INTEGER BUFADD
  2172.  
  2173. C NELS is the number of elements to transfer.
  2174.  
  2175.     INTEGER NELS
  2176.  
  2177. C ARRINT is the array of the field in internal form.
  2178.  
  2179.     INTEGER*2 ARRINT(100)
  2180.  
  2181. C WCNT is a count of the current number of the word to transfer
  2182.  
  2183.     INTEGER WCNT
  2184.  
  2185.     INTEGER C
  2186.  
  2187.  
  2188.     COMMON/MSGBUF/WBUF(1)
  2189.     INTEGER*2 WBUF
  2190.  
  2191. C If the field is scalar then only transfer 1 field .
  2192.  
  2193.     IF (NELS.EQ.0) NELS=1
  2194.  
  2195.  
  2196. C Transfer from the message buffer into arrint 
  2197.  
  2198.     IF (SENSE.EQ.-1) THEN
  2199.        DO WCNT=0,(NELS*2)-1
  2200.           WBADD=BUFADD+WCNT        
  2201.           ARRINT(WCNT+1)=WBUF(WBADD)
  2202.        ENDDO
  2203.  
  2204. C Transfer from arrint into the message buffer .
  2205.  
  2206.     ELSE
  2207.        DO WCNT=0,(NELS*2)-1
  2208.           WBADD=BUFADD+WCNT        
  2209.           WBUF(WBADD)=ARRINT(WCNT+1)
  2210.        ENDDO
  2211.     ENDIF
  2212.  
  2213. C Calculate the position in the message buffer for the nextf iled .
  2214.  
  2215.     BUFADD=BUFADD+(NELS*2)
  2216.  
  2217.  
  2218.     RETURN
  2219.     END
  2220.  
  2221.  
  2222.  
  2223.  
  2224.  
  2225.     SUBROUTINE R8CV01(SENSE , BUFADD , NELS , ARRINT)
  2226.  
  2227.  
  2228. C------------------------------------------------------------------------------
  2229. C
  2230. C Function        : Get an integer field from the message buffer starting at 
  2231. C                   address BUFADD convert to internal format and place
  2232. C                   in output array arrint . Note that npo conversion is infact
  2233. C                   needed and the process is a straight copy .
  2234. C                   Or transfer from the arrint array imnto the message buffer
  2235. C
  2236. C Input arguments : SENSE = -1 => Move field Message buffer -> Arrint
  2237. C                   SENSE = 1 => Move field arrint -> message buffer .
  2238. C                   BUFADD : the address in the word message buffer .        
  2239. C                   NELS : the number of elements to transfer .
  2240. C
  2241. C Output arguments: BUFADD
  2242. C                   ARRINT : Output is sense = -1 and moving into arrint .
  2243. C
  2244. C Common blocks   : The common message buffer wbuf .
  2245. C
  2246. C Called by       : PUTREC , GETREC , R8COND .
  2247. C
  2248. C Calls           : None .
  2249. C
  2250. C Author          :                        (  /  /  )     Version 1.0
  2251. C
  2252. C Amendments      :                        (  /  /  )
  2253. C
  2254. C Notes           : 
  2255. C
  2256. C------------------------------------------------------------------------------
  2257.  
  2258.  
  2259.  
  2260. C SENSE decides in which direction the transferance is to be (see header)
  2261.  
  2262.     INTEGER SENSE
  2263.  
  2264. C BUFADD is the address in the message buffer.
  2265.  
  2266.     INTEGER BUFADD
  2267.  
  2268. C NELS is the number of elements to transfer.
  2269.  
  2270.     INTEGER NELS
  2271.  
  2272. C ARRINT is the array of the field in internal form.
  2273.  
  2274.     INTEGER*2 ARRINT(50)
  2275.  
  2276. C WCNT is a count of the current number of the word to transfer
  2277.  
  2278.     INTEGER WCNT
  2279.  
  2280.  
  2281.  
  2282.  
  2283.     COMMON/MSGBUF/WBUF(1)
  2284.     INTEGER*2 WBUF
  2285.  
  2286.  
  2287.  
  2288. C If the field is scalar then only 1 elemnt needs to be transfered .
  2289.  
  2290.     IF (NELS.EQ.0) NELS=1
  2291.  
  2292. C Transfer from the message buffer into arrint .
  2293.  
  2294.     IF (SENSE.EQ.-1) THEN
  2295.        DO WCNT=0,(NELS*2)-1
  2296.           WBADD=BUFADD+WCNT        
  2297.           ARRINT(WCNT+1)=WBUF(WBADD)
  2298.        ENDDO
  2299.  
  2300. C Transfer into arrint from the message buffer .
  2301.  
  2302.     ELSE
  2303.        DO WCNT=0,(NELS*2)-1
  2304.           WBADD=BUFADD+WCNT        
  2305.           WBUF(WBADD)=ARRINT(WCNT+1)
  2306.        ENDDO
  2307.     ENDIF
  2308.  
  2309. C Calculate the start int the message buffer for the next field .
  2310.  
  2311.     BUFADD=BUFADD+(NELS*2)
  2312.  
  2313.     RETURN
  2314.     END
  2315.  
  2316.  
  2317.     SUBROUTINE R8CV03(SENSE,BUFADD,NELS,NCHARS,ARRINT)
  2318.  
  2319.  
  2320.  
  2321. C------------------------------------------------------------------------------
  2322. C
  2323. C Function        : Get an character field from the message buffer starting at 
  2324. C                   address BUFADD convert to internal format and place
  2325. C                   in output array arrint . Note that npo conversion is infact
  2326. C                   needed and the process is a straight copy . Or get the 
  2327. C                   field from the ipb and put into the message buffer .
  2328. C                    
  2329. C
  2330. C Input arguments : SENSE = -1 => Move field Message buffer -> Arrint
  2331. C                   SENSE = 1 => Move field arrint -> message buffer .
  2332. C                   BUFADD : the address in the word message buffer .        
  2333. C                   NELS : the number of elements to transfer .
  2334. C                   NCHARS : the number of characters in an element string .
  2335. C
  2336. C Output arguments: BUFADD
  2337. C                   ARRINT : Output is sense = -1 and moving into arrint .
  2338. C
  2339. C Common blocks   : The common message buffer wbuf .
  2340. C
  2341. C Called by       : PUTREC , GETREC , R8COND .
  2342. C
  2343. C Calls           : None .
  2344. C
  2345. C Author          :                        (  /  /  )     Version 1.0
  2346. C
  2347. C Amendments      :                        (  /  /  )
  2348. C
  2349. C Notes           : 
  2350. C
  2351. C------------------------------------------------------------------------------
  2352.  
  2353.  
  2354.  
  2355. C SENSE is the direction of conversion ( see header )
  2356.  
  2357.     INTEGER SENSE
  2358.  
  2359. C BUFADD is the address in the word buffer
  2360.  
  2361.     INTEGER BUFADD
  2362.  
  2363. C NELS is the number of elements.
  2364.  
  2365.     INTEGER NELS
  2366.  
  2367. C NCHARS is the number of characters per element.
  2368.  
  2369.     INTEGER NCHARS
  2370.  
  2371. C ARRINT is the byte array into which the field is placed or taken from
  2372. C depending on sense.Note that it is passed in as a word array and declared
  2373. C here as a byte array .
  2374.  
  2375.     BYTE ARRINT(400)
  2376.  
  2377. C CCNT is a byte count of the characters transfered .
  2378. C CBUFADD is the current position in thecharacter buffer .
  2379. C CMOVE is the number of characters to move .
  2380.  
  2381.     INTEGER CCNT,CBUFAD,CMOVE,ECNT,IND
  2382.  
  2383.  
  2384. C Characters are taken/put from the array cbuf a byte array equivalenced
  2385. C to the message buffer .
  2386.  
  2387.         COMMON/MSGBUF/WBUF(100)
  2388.     INTEGER*2 WBUF
  2389.  
  2390.     BYTE CBUF(200)
  2391.     EQUIVALENCE (CBUF,WBUF)
  2392.  
  2393.  
  2394.  
  2395. C If the field is scalar then the number of elements to move is 1 .
  2396.  
  2397.     IF (NELS.EQ.0) NELS=1
  2398.  
  2399.  
  2400. C BUFADD is the address in the message buffer in words soit must be
  2401. C converted into an address in the byte buffer .
  2402.  
  2403.     CBUFAD=(BUFADD*2)-1
  2404.  
  2405.     CMOVE=(NELS*NCHARS)
  2406.  
  2407.  
  2408. C Transfer from the message buffer into the arrint array .
  2409.         
  2410.         IF (SENSE.EQ.-1) THEN
  2411.        DO ECNT=1,NELS
  2412.               DO CCNT=1,NCHARS
  2413.                  IND = (ECNT-1)*NCHARS + CCNT
  2414.                  ARRINT(IND)=CBUF(CBUFAD)
  2415.              CBUFAD=CBUFAD+1
  2416.               ENDDO   
  2417.               CBUFAD = ((CBUFAD/2)*2)+1
  2418.        ENDDO
  2419.  
  2420. C In RAPPORT all fields must start and finish on a long word boundary .
  2421. C So it is neccesary in the case of a character field (which is not
  2422. C automatically long word aligned) to pad arrit out to a long word 
  2423. C boundary with spaces (ASCII decimal 32) as does RAPPORT 
  2424.  
  2425.  
  2426.            DO CCNT=(CMOVE+1),((CMOVE+3)/4)*4
  2427.               ARRINT(CCNT)=32
  2428.            ENDDO
  2429.  
  2430.  
  2431. C Move from ARRINT into the message buffer.
  2432.  
  2433.     ELSE
  2434.  
  2435.  
  2436.        DO ECNT=1,NELS
  2437.               DO CCNT=1,NCHARS
  2438.                  IND = (ECNT-1)*NCHARS + CCNT
  2439.                  CBUF(CBUFAD) = ARRINT(IND)
  2440.              CBUFAD=CBUFAD+1
  2441.               ENDDO   
  2442.               CBUFAD = ((CBUFAD/2)*2)+1
  2443.        ENDDO
  2444.  
  2445.  
  2446.     ENDIF
  2447.  
  2448. C Note that in an ada record each field of that record must be WORD
  2449. C aligned (i.e. 16 bit).With a character field if we have an odd number of
  2450. C characters then thgis is not the case.The address then must be rounded
  2451. C up to the next word in the message buffer .
  2452.  
  2453.     BUFADD=(CBUFAD+2)/2
  2454.  
  2455.  
  2456.  
  2457.  
  2458.  
  2459.  
  2460.     RETURN
  2461.     END
  2462.                          
  2463.  
  2464. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  2465. --V23USR.MAR
  2466. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  2467.     .TITLE    ROSUSR.MAR    ROS 2.2    VMS USER SUPPORT
  2468.     .IDENT    /V2.3a/
  2469.     
  2470.     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2471.     ;                                  ;
  2472.     ;    ROS 2.2    VMS USER SUPPORT                  ;
  2473.     ;                                  ;
  2474.     ;    Written    by                          ;
  2475.     ;                                  ;
  2476.     ;    H. Rutherford    12-Sep-83                  ;
  2477.     ;                                  ;
  2478.     ;    Copyright (c) TeleSoft 1983                  ;
  2479.     ;    All Rights Reserved                      ;
  2480.     ;                                  ;
  2481.     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2482.  
  2483.     ;--------------------------------------------------------------
  2484.     ; Bug List    BUGS bugs BUGS bugs
  2485.     ;
  2486.     ; when      who    bug#    Description of problem
  2487.     ;
  2488.     ;
  2489.     ;--------------------------------------------------------------
  2490.     ; Log of Modifications    LOG  log
  2491.     ;
  2492.     ; when      who    version    where    what
  2493.     ;
  2494.     ; 30/1/85 MDD 
  2495.         ;
  2496.     ; 
  2497.     ;--------------------------------------------------------------
  2498.     
  2499.     
  2500.     .PSECT    ROSUSR    LONG,EXE
  2501.     
  2502.     .SAVE_PSECT
  2503.  
  2504.     .PSECT    ROSDAT    LONG,CON,NOEXE,WRT,NOSHR,REL,PIC
  2505.     
  2506. USRDRVRT::
  2507.     .ADDRESS    USRDRVRT    ; empty    queue
  2508.     .ADDRESS    USRDRVRT    ;
  2509.     .ADDRESS    USRSTART    ;
  2510.     .ADDRESS    USRCLR        ;
  2511.     .ADDRESS    USRCNTRL    ;
  2512.     .WORD        0
  2513.     .WORD        0
  2514.     
  2515.     .ALIGN    LONG,0
  2516.     
  2517. USRFAB::$FAB-            ; Default FAB
  2518.       SHR=<GET,PUT,UPD,DEL,UPI>
  2519. USRNAM:    $NAM            ; Default NAM
  2520. USRRAB:    $RAB            ; Default RAB
  2521.  
  2522.     $IODEF
  2523.         $PRCDEF
  2524.         $DVIDEF
  2525.  
  2526.  
  2527.  
  2528.  
  2529. ; In setting the input and output of the process that we create to the
  2530. ; terminal we need to discover the name of the device.This is done via
  2531. ; a call to the system service $GETDVI_S hich takes as an argument the
  2532. ; DVILIST so described.
  2533.  
  2534.  
  2535. DVILIST:
  2536.         .WORD   64
  2537.         .WORD   DVI$_DEVNAM
  2538.         .ADDRESS -
  2539.                 TERM
  2540.         .ADDRESS -
  2541.                 TERMDESC
  2542.         .LONG   0
  2543.  
  2544. TERMDESC:
  2545.         .WORD   64
  2546.         .WORD   0
  2547. TERMADDR:
  2548.         .ADDRESS -
  2549.                 TERM
  2550. CONCTERM:
  2551.         .ASCII  /_/
  2552. TERM:   .BLKB   64
  2553.  
  2554.  
  2555. ;The name of the terminal is derived by GETDVI from the logical name assigned
  2556. ;to it which is SYS$INPUT
  2557.  
  2558. LOGNAM: .ASCID  /SYS$INPUT/
  2559.  
  2560.  
  2561. ; We will also need to discover the name of the mailbox that we create as
  2562. ; on creation of the mailbox it is only identifiable by its channel number
  2563. ; and when the process is created we need to know its logical name
  2564.  
  2565.  
  2566. MBXLIST:
  2567.         .WORD   64
  2568.         .WORD   DVI$_DEVNAM
  2569.         .ADDRESS -
  2570.                 MBX
  2571.         .ADDRESS -
  2572.                 MBXDESC
  2573.         .LONG   0
  2574.  
  2575. MBXDESC:
  2576.         .WORD   64
  2577.         .WORD   0
  2578. MBXADDR:
  2579.         .ADDRESS -
  2580.                 MBX
  2581. CONCMBX:
  2582.         .ASCII  /_/
  2583. MBX:    .BLKB   64
  2584.  
  2585.  
  2586.  
  2587.  
  2588. ; There follows declarations of theinformation needed to set up and maintain
  2589. ; the mailbox lionk to user call lib:-
  2590. ;
  2591. ;               A longword to hold the channel number of the mailbox
  2592. ;
  2593.  
  2594.  
  2595. MESSAGEPIPE:
  2596.         .BLKW   1
  2597.  
  2598.  
  2599.  
  2600. ; This is the declaration of the message buferr which is a contiguous sequence
  2601. ; of longwords enough to hold the largest possible message
  2602.  
  2603.  
  2604. MESSAGE:
  2605.         .BLKL   50       
  2606.  
  2607.  
  2608. ; This is a character descriptor of the name and location of user call lib.
  2609. ; This descriptor is used by $CREPRC to set up and run user call lib in
  2610. ; parallel with the ada application progam
  2611.  
  2612.  
  2613. USERCALLLIB:
  2614.         .ASCID   /DBA2:[ADARAPP.FORTRAN]usercall.exe/
  2615.  
  2616.  
  2617.  
  2618. ; This is the argument list used by SIMPLE , RECWRIE , RECREAD to store
  2619. ; and access two pointers :-
  2620. ;
  2621. ;               ENDADAREC : A pointer to the description (if it exists)
  2622. ;                           of the size and position of the database record
  2623. ;                           in ada address space.
  2624. ;               END MESSAGE : A pointer to the start of a sequence of long
  2625. ;                             words in the message buffer that hold (or are
  2626. ;                             to hold the database record.
  2627.  
  2628.  
  2629. ADDRLIST:
  2630.         .LONG    2
  2631.         .ADDRESS ENDADARECORD,ENDMESSAGE
  2632.  
  2633. ENDADARECORD:
  2634.         .BLKL   1
  2635.  
  2636. ENDMESSAGE:
  2637.         .BLKL   1
  2638.  
  2639.  
  2640.  
  2641. ; This is the argument list used to give the parameters for a data transferal
  2642. ; to TRANSFER and to return pointers to the nex available byte in both data
  2643. ; areas after data transferal.It is used by TRANSFER , ADATOMSG , MSGTOADA
  2644. ; ATOMREC , MTOAREC . Its parts are:-
  2645. ;
  2646. ;           FROM : The start address of the data to transfer.
  2647. ;           TO : The start of the data area to transfer the data to.
  2648. ;           SIZE : The amount of words of data to transfer.
  2649. ;           ENDFROM : The first available byte in the from area.
  2650. ;           ENDTO : The first available byte in the to area.
  2651. ;
  2652.  
  2653.  
  2654. TRANSPARAMS:
  2655.         .LONG   5 
  2656.         .ADDRESS FROMSTART,TOSTART,SIZE,ENDFROM,ENDTO
  2657.       
  2658. FROMSTART:
  2659.         .BLKL   1
  2660.  
  2661. TOSTART:
  2662.         .BLKL   1
  2663.  
  2664. SIZE:   .BLKL   1
  2665.  
  2666. ENDFROM:
  2667.         .BLKL   1
  2668.  
  2669. ENDTO:  .BLKL   1
  2670.         
  2671.  
  2672. DUMMY:  .BLKL   1
  2673.  
  2674.  
  2675.     .ALIGN    LONG,0
  2676.  
  2677.  
  2678.     .RESTORE_PSECT
  2679.  
  2680.  
  2681.  
  2682.     ;-------------------------------------
  2683.     ;  R1 =    ^ TO TASK CONTROL BLOCK
  2684.     ;  R2 =    scratch
  2685.     ;  R6 =    untouchable
  2686.     ;  R8 =    task stack pointer
  2687.     ;  R9 =    scratch
  2688.     ;  R10= scratch    
  2689.     ;
  2690.     ;  The following are general constants
  2691.     ;
  2692.     ;-------------------------------------
  2693.     
  2694. ACSZE    =    256.    ; Size of an ASCII packed array    (also size of bufs)
  2695.             ; The actual size is 255, but 256 bytes are allocated
  2696. ADSZE    =  8. +    ACSZE    ; The size of an ASCID record
  2697.  
  2698. ;
  2699. ; Argument offsets in parameter block
  2700. ;
  2701. WHAT    =    0    ; What call kind it is
  2702. P1    =    4    ; First parameter
  2703. P2    =    8    ; Second parameter
  2704. P3    =    12    ; Third parameter
  2705. RESULT  =       16    ; The result of this call
  2706. ERRNO    =    20    ; The system result
  2707.  
  2708.  
  2709. ; This is a list of mnemonic equating the various service call to rapport
  2710. ; with their equivalent integer identifiers
  2711.  
  2712.  
  2713. STARTRAPPORT  =  1
  2714. ENDRAPPORT    =  2
  2715. TRANSACT      =  3
  2716. COMMIT        =  4
  2717. BACKOUT       =  5
  2718. INSERT        =  6
  2719. UPDATE        =  7 
  2720. STORE         =  8 
  2721. CONDITION     =  9
  2722. FETCH         =  10
  2723. DELETE        =  11    
  2724. STACK         =  12
  2725. STOREKEY      =  13
  2726. HOLD          =  14
  2727. ENDRETRIEVE   =  15  
  2728. ENDSEARCH     =  16
  2729. RETRIEVE      =  17
  2730. CLEARFILE     =  18
  2731. LOCK          =  19
  2732.  
  2733.  
  2734.  
  2735.  
  2736.  
  2737.  
  2738.  
  2739. USRSTART::      ;--------- start of code --------
  2740.         PUSHR   #^M<R2,R3,R4,R5,R6,R7,R8,R9,R10>
  2741.         MOVL    TSP(R1),R8                      ; get task stack pointer
  2742.         MOVL    BUFFER(R8),R8                   ; get param block
  2743.  
  2744. ;------------------------------------------------------------------------------
  2745. ;
  2746. ; Function        :  * If the call is StartRapport then set up communications.
  2747. ;                    * Dispatch the call to the appropriate handling routine:-
  2748. ;                                   - Simple
  2749. ;                                   - Recread
  2750. ;                                   - Recwrite
  2751. ;                    * If the call is EndRapport then shut down the mailbox. 
  2752. ;
  2753. ; Input arguments : None
  2754. ;
  2755. ; Output arguments: None
  2756. ;
  2757. ; Common blocks   : Acceses the the parameter WHAT(The service call number).
  2758. ;
  2759. ; Calls To        : SETCOMS , BRKCOMS , SIMPLE , RECREAD , RECWRITE
  2760. ;
  2761. ; Called By       : A da application program.
  2762. ;
  2763. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  2764. ;
  2765. ; Amendments      :                        (  /  /  )
  2766. ;
  2767. ; Notes           : 
  2768. ;
  2769. ;------------------------------------------------------------------------------
  2770.  
  2771.         CMPL    WHAT(R8),#STARTRAPPORT
  2772.         BNEQ    DISPATCHER
  2773.         CALLS   #0,SETCOMS
  2774.  
  2775. DISPATCHER:
  2776.         CMPL    WHAT(R8),#STARTRAPPORT
  2777.         BNEQ    CONT1
  2778.         CALLS   #0,SIMPLE
  2779.         JMP     QUIT
  2780. CONT1:  CMPL    WHAT(R8),#ENDRAPPORT
  2781.         BNEQ    CONT2
  2782.         CALLS   #0,SIMPLE
  2783.         CALLS   #0,BRKCOMS
  2784.         JMP     QUIT
  2785. CONT2:  CMPL    WHAT(R8),#TRANSACT
  2786.         BNEQ    CONT3
  2787.         CALLS   #0,SIMPLE
  2788.         JMP     QUIT
  2789. CONT3:  CMPL    WHAT(R8),#COMMIT
  2790.         BNEQ    CONT4
  2791.         CALLS   #0,SIMPLE
  2792.         JMP     QUIT
  2793. CONT4:  CMPL    WHAT(R8),#BACKOUT
  2794.         BNEQ    CONT5
  2795.         CALLS   #0,SIMPLE
  2796.         JMP     QUIT
  2797. CONT5:  CMPL    WHAT(R8),#INSERT
  2798.         BNEQ    CONT6
  2799.         CALLS   #0,RECWRITE
  2800.         JMP     QUIT
  2801. CONT6:  CMPL    WHAT(R8),#UPDATE
  2802.         BNEQ    CONT7
  2803.         CALLS   #0,RECWRITE
  2804.         JMP     QUIT
  2805. CONT7:  CMPL    WHAT(R8),#STORE
  2806.         BNEQ    CONT8
  2807.         CALLS   #0,RECWRITE
  2808.         JMP     QUIT
  2809. CONT8:  CMPL    WHAT(R8),#CONDITION
  2810.         BNEQ    CONT9
  2811.         CALLS   #0,RECWRITE
  2812.         JMP     QUIT
  2813. CONT9:  CMPL    WHAT(R8),#FETCH
  2814.         BNEQ    CONT10
  2815.         CALLS   #0,RECREAD
  2816.         JMP     QUIT
  2817. CONT10: CMPL    WHAT(R8),#DELETE
  2818.         BNEQ    CONT11
  2819.         CALLS   #0,SIMPLE
  2820.         JMP     QUIT
  2821. CONT11: CMPL    WHAT(R8),#STACK
  2822.         BNEQ    CONT12
  2823.         CALLS   #0,SIMPLE
  2824.         JMP     QUIT
  2825. CONT12: CMPL    WHAT(R8),#STOREKEY
  2826.         BNEQ    CONT13
  2827.         CALLS   #0,RECWRITE
  2828.         JMP     QUIT
  2829. CONT13: CMPL    WHAT(R8),#HOLD
  2830.         BNEQ    CONT14
  2831.         CALLS   #0,SIMPLE
  2832.         JMP     QUIT
  2833. CONT14: CMPL    WHAT(R8),#ENDRETRIEVE
  2834.         BNEQ    CONT15
  2835.         CALLS   #0,SIMPLE
  2836.         JMP     QUIT
  2837. CONT15: CMPL    WHAT(R8),#ENDSEARCH
  2838.         BNEQ    CONT16
  2839.         CALLS   #0,SIMPLE
  2840.         JMP     QUIT
  2841. CONT16: CMPL    WHAT(R8),#RETRIEVE
  2842.         BNEQ    CONT17
  2843.         CALLS   #0,RECREAD
  2844.         JMP     QUIT
  2845. CONT17: CMPL    WHAT(R8),#CLEARFILE
  2846.         BNEQ    CONT18
  2847.         CALLS   #0,SIMPLE
  2848.         JMP     QUIT
  2849. CONT18: CMPL    WHAT(R8),#LOCK
  2850.         BNEQ    CONT19
  2851.         CALLS   #0,SIMPLE
  2852.         JMP     QUIT
  2853. CONT19: JMP     QUIT
  2854.  
  2855.  
  2856.  
  2857.  
  2858. ;------------------------------------------------------------------------------
  2859. ;
  2860. ; Function        :      * Set up a mailbox.
  2861. ;                        * Find the logical name of the terminal.
  2862. ;                        * Find the logical name of the mailbox just created
  2863. ;                        * Create the user call lib process setting the input
  2864. ;                          and output channels equal to the terminal and the
  2865. ;                          error channel(for the passage of the messages) equal
  2866. ;                          to the mailbox name.
  2867. ;                        * Place the channel of the mailbox in the return
  2868. ;                          location for the syscall function.
  2869. ;
  2870. ; Input arguments : None
  2871. ;
  2872. ; Output arguments: None
  2873. ;
  2874. ; Globals Used    : syscall result (RESULT(R8)) , Terminal descriptor (DVILIST)
  2875. ;                   Mailbox descriptor (MBXLIST) , Channel number (MESSAGEPIPE)
  2876. ;
  2877. ; Calls To        : System services :- $CREMBX , $GETDVI , $CREPRC
  2878. ;
  2879. ; Called By       : Main
  2880. ;
  2881. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  2882. ;
  2883. ; Amendments      :                        (  /  /  )
  2884. ;
  2885. ; Notes           : 
  2886. ;
  2887. ;------------------------------------------------------------------------------
  2888.  
  2889.  
  2890.         .ENTRY    SETCOMS,^M<R4,R5>
  2891.         $CREMBX_S CHAN=MESSAGEPIPE         ; Create the mailbox
  2892.         $GETDVI_S DEVNAM=LOGNAM,-          ; Get the device name of the
  2893.                 ITMLST=DVILIST             ; terminal
  2894.         $GETDVI_S CHAN=MESSAGEPIPE,-       ; Get the device name of the
  2895.                 ITMLST=MBXLIST             ; mailbox
  2896.         $CREPRC_S IMAGE=USERCALLLIB,-      ; Create a process to run user
  2897.                 INPUT=TERMDESC,-           ; call lib and set the input,output
  2898.                 OUTPUT=TERMDESC,-          ; and error channels to appropriate
  2899.                 ERROR=MBXDESC              ; devices.
  2900.         MOVL    MESSAGEPIPE,RESULT(R8)     ; Put the channel number in fn ret.
  2901.         RET
  2902.  
  2903.  
  2904.  
  2905.  
  2906. ;------------------------------------------------------------------------------
  2907. ;
  2908. ; Function        :       * Unhook the channel from the mailbox.
  2909. ;
  2910. ; Input arguments : None.
  2911. ;
  2912. ; Output arguments: None.
  2913. ;
  2914. ; Globals Used    : MESSAGEPIPE:-Address of the channel number.
  2915. ;                   The cahnnel number passed from syscall (P3(R8))
  2916. ;
  2917. ; Calls To        : System service:- $DASSGN
  2918. ;
  2919. ; Called By       : Called from ENDRAPPORT section of DISPATCHER.
  2920. ;
  2921. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  2922. ;
  2923. ; Amendments      :                        (  /  /  )
  2924. ;
  2925. ; Notes           : 
  2926. ;
  2927. ;------------------------------------------------------------------------------
  2928.  
  2929.  
  2930.     .ENTRY    BRKCOMS,^M<R4,R5>
  2931.     MOVL    P3(R8),MESSAGEPIPE
  2932.     $DASSGN_S CHAN=MESSAGEPIPE
  2933.     RET
  2934.  
  2935.  
  2936.  
  2937.  
  2938.  
  2939. ;------------------------------------------------------------------------------
  2940. ;
  2941. ; Function        :       * Transfer the parameters from ada record to the
  2942. ;                           message buffer.
  2943. ;                         * Communicate with user call lib.
  2944. ;                         * Transfer the parameters back from the message 
  2945. ;                           buffer into the ada record. 
  2946. ;
  2947. ; Input arguments : None.
  2948. ;
  2949. ; Output arguments: None.
  2950. ;
  2951. ; Globals Used    : ADDRLIST (used to call sub-procedures but not accessed)
  2952. ;
  2953. ; Calls To        : ADATOMSG , RAPCOMS , MSGTOADA
  2954. ;
  2955. ; Called By       : Dispatcher parts ( .. )
  2956. ;
  2957. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  2958. ;
  2959. ; Amendments      :                        (  /  /  )
  2960. ;
  2961. ; Notes           : 
  2962. ;
  2963. ;------------------------------------------------------------------------------
  2964.  
  2965.  
  2966.         .ENTRY    SIMPLE,^M<R4,R5>
  2967.     CALLG    ADDRLIST,ADATOMSG        ; Move static parameters to message.
  2968.     CALLS   #0,RAPCOMS               ; Talk to user call lib.
  2969.     CALLG    ADDRLIST,MSGTOADA        ; Transfer back static parameters. 
  2970.     RET
  2971.  
  2972.  
  2973. ;------------------------------------------------------------------------------
  2974. ;
  2975. ; Function        :      * Transfer static parameters from ada record space 
  2976. ;                          the message buffer.
  2977. ;                        * Transfer the variable length database record from
  2978. ;                          ada space to the message buffer.
  2979. ;                        * Communicate with user call lib.
  2980. ;                        * Transfer the static parameters back from the
  2981. ;                          message buffer into the ada record. 
  2982. ;
  2983. ; Input arguments : None.
  2984. ;
  2985. ; Output arguments: None.
  2986. ;
  2987. ; Globals Used    : ADDRLIST The elements of this tell the procedure where
  2988. ;                   to find the description of the database record (ENDADA)
  2989. ;                   and where to put it (ENDMESSAGE).This information is
  2990. ;                   passed to AtoMREC.
  2991. ;
  2992. ; Calls To        : ADATOMSG , ATOMREC , RAPCOMS , MSGTOADA
  2993. ;
  2994. ; Called By       : DISPATCHER parts ( .. )
  2995. ;
  2996. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  2997. ;
  2998. ; Amendments      :                        (  /  /  )
  2999. ;
  3000. ; Notes           : 
  3001. ;
  3002. ;------------------------------------------------------------------------------
  3003.  
  3004.  
  3005.         .ENTRY    RECWRITE,^M<R4,R5>
  3006.     CALLG    ADDRLIST,ADATOMSG         ; Move static parameters to 
  3007.                                           ; message buffer 
  3008.     CALLG    ADDRLIST,ATOMREC          ; Move the variable length part 
  3009.                                           ; to the message buffer.
  3010.     CALLS    #0,RAPCOMS                ; Talk to user call lib.
  3011.     CALLG    ADDRLIST,MSGTOADA         ; Return the static parameters
  3012.                                           ; back from the message buffer.
  3013.     RET
  3014.  
  3015.  
  3016.  
  3017. ;------------------------------------------------------------------------------
  3018. ;
  3019. ; Function        :        * Transfer the static parameters from the ada
  3020. ;                            record to the message buffer.
  3021. ;                          * Communicate with user call lib.
  3022. ;                          * Transfer the static parameters back from the
  3023. ;                            message buffer into the ada record.
  3024. ;                          * Transfer the database record returned by user
  3025. ;                            call lib from the meesage buffer  to the ada
  3026. ;                            database record. 
  3027. ;
  3028. ; Input arguments : None
  3029. ;
  3030. ; Output arguments: None.
  3031. ;
  3032. ; Globals Used    : ADDRLIST containing information about where to put the 
  3033. ;                   record (ENDADA) and where to find it (ENDMESSAGE) this
  3034. ;                   information is passed to MtoAREC.
  3035. ;
  3036. ; Calls To        : ADATOMSG , RAPCOMSD , MSGTOADA , MTOAREC
  3037. ;
  3038. ; Called By       : DISPATCHER parts ( .. )
  3039. ;
  3040. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  3041. ;
  3042. ; Amendments      :                        (  /  /  )
  3043. ;
  3044. ; Notes           : 
  3045. ;
  3046. ;------------------------------------------------------------------------------
  3047.  
  3048.  
  3049.         .ENTRY    RECREAD,^M<R4,R5>        
  3050.     CALLG    ADDRLIST,ADATOMSG        ; Transfer the static parameters
  3051.                                          ; to the message buffer.
  3052.     CALLS    #0,RAPCOMS               ; Talk to user call lib.
  3053.     CALLG    ADDRLIST,MSGTOADA        ; Return the static parameters from
  3054.                                          ; the message buffer.
  3055.     CALLG    ADDRLIST,MTOAREC         ; Move the variable length part from
  3056.                                          ; the message buffer to ada space.
  3057.     RET
  3058.  
  3059.  
  3060.  
  3061. ;------------------------------------------------------------------------------
  3062. ;
  3063. ; Function        :     * Move the number of the service call to the first
  3064. ;                         longword of the message buffer.
  3065. ;                       * Get the size and start address of the static
  3066. ;                         parameters and move them to the message buffer.
  3067. ;                       * Put the address of the end of the static parameters
  3068. ;                         and the address reached in the message buffer into
  3069. ;                         thereturn parameters.
  3070. ;           
  3071. ; Input arguments : None.
  3072. ;
  3073. ; Output arguments:     1.) The address of the first byte after the static
  3074. ;                           parameters and also the address of the record
  3075. ;                           descriptor - if there is one .
  3076. ;                        2.)The address in the message buffer after the
  3077. ;                           static parameters have been transfered.
  3078. ;
  3079. ; Globals Used    : TRANSPARAMS as the argument list to call transfer.
  3080. ;
  3081. ; Calls To        : TRANSFER.
  3082. ;
  3083. ; Called By       : SIMPLE , RECWRITE , RECREAD
  3084. ;
  3085. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  3086. ;
  3087. ; Amendments      :                        (  /  /  )
  3088. ;
  3089. ; Notes           : 
  3090. ;
  3091. ;------------------------------------------------------------------------------
  3092.  
  3093.  
  3094.         .ENTRY    ADATOMSG,^M<R4,R5>
  3095.     MOVL    P1(R8),FROMSTART        ; Move the start of the parameter
  3096.                                         ; record to FROMSTART which will be
  3097.                                         ; passed to transfer.
  3098.     MOVL    P2(R8),SIZE             ; Likewise move the size of the 
  3099.                                         ; parameter record to SIZE.
  3100.     MOVL    #MESSAGE,R4             ; Address of the message buffer to r4
  3101.     MOVL    WHAT(R8),(R4)+          ; Move the number of the service call
  3102.                                         ; to the message buffer.   
  3103.     MOVL    R4,TOSTART              ; Move r4 (first free byte in buffer)
  3104.                                         ; to TOSTART.
  3105.       CALLG    TRANSPARAMS,TRANSFER    ; Do the data transfer FROMSTART ->
  3106.                                         ; TOSTART.
  3107.         MOVL    (AP)+,DUMMY             ; Correctly align the argument pointer.
  3108.     MOVL    ENDFROM,@(AP)+          ; Move ENDFROM and ENDTO  to the 
  3109.         MOVL    ENDTO,@(AP)+            ; ouput parameters.
  3110.     RET
  3111.  
  3112.  
  3113.  
  3114.  
  3115. ;------------------------------------------------------------------------------
  3116. ;
  3117. ; Function        :     * Move the number of the service call from the message
  3118. ;                         to align the pointers correctle.
  3119. ;                       * Get the size and start address of the static
  3120. ;                         parameters in ada space and move them there from
  3121. ;                         the message buffer.
  3122. ;                       * Put the address of the end of the static parameters
  3123. ;                         and the address reached in the message buffer into
  3124. ;                         thereturn parameters.
  3125. ;           
  3126. ; Input arguments : None.
  3127. ;
  3128. ; Output arguments:     1.) The address of the first byte after the static
  3129. ;                           parameters and also the address of the record
  3130. ;                           descriptor - if there is one )
  3131. ;                       2.) The address in the message buffer after the
  3132. ;                           static parameters have been transfered)
  3133. ;
  3134. ; Globals Used    : TRANSPARAMS as the argument list to call transfer.
  3135. ;
  3136. ; Calls To        : TRANSFER.
  3137. ;
  3138. ; Called By       : SIMPLE , RECWRITE , RECREAD
  3139. ;
  3140. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  3141. ;
  3142. ; Amendments      :                        (  /  /  )
  3143. ;
  3144. ; Notes           : 
  3145. ;
  3146. ;------------------------------------------------------------------------------
  3147.  
  3148.  
  3149.         .ENTRY    MSGTOADA,^M<R4,R5>
  3150.     MOVL    P1(R8),TOSTART        ; Move the address of the pasrameter
  3151.                                       ; record to TOSTART which is used by
  3152.                                       ; transfer.
  3153.     MOVL    P2(R8),SIZE           ; Likewise with the size of the params.
  3154.     MOVL    #MESSAGE,R4           ; address of message buffer -> r4
  3155.     MOVL    WHAT(R8),(R4)+        ; Move the number of the service call
  3156.                                       ; to the message buffer
  3157.     MOVL    R4,FROMSTART          ; Move the address of the place in the
  3158.                                       ; message buffer to get parameters from.
  3159.       CALLG    TRANSPARAMS,TRANSFER  ; Do the data transfer .
  3160.         MOVL    (AP)+,DUMMY           ; Align argument pointer.
  3161.     MOVL    ENDTO,@(AP)+          ; Move ENDTO and ENDFROM to the
  3162.     MOVL    ENDFROM,@(AP)+         ; Output parameters.
  3163.     RET
  3164.      
  3165.  
  3166.  
  3167. ;------------------------------------------------------------------------------
  3168. ;
  3169. ; Function        :        * Move the size and start address of the record in
  3170. ;                            ada store along with the addres in the message
  3171. ;                            buffer to transfger to to the transfer parameters
  3172. ;                          * Transfer the record to the message buffer 
  3173. ;
  3174. ; Input arguments :        1.) The address of the record description in ada 
  3175. ;                              space.
  3176. ;                          2.) The address to transfer to in the message
  3177. ;                              buffer.
  3178. ;
  3179. ; Output arguments: None.
  3180. ;
  3181. ; Globals Used    : The transfer parameters used as argument list for transfer
  3182. ;
  3183. ; Calls To        : TRANSFER
  3184. ;
  3185. ; Called By       : RECWRITE
  3186. ;
  3187. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  3188. ;
  3189. ; Amendments      :                        (  /  /  )
  3190. ;
  3191. ; Notes           : 
  3192. ;
  3193. ;------------------------------------------------------------------------------
  3194.  
  3195.  
  3196.  
  3197.         .ENTRY    ATOMREC,^M<R2,R4>
  3198.         MOVL    (AP)+,DUMMY          ; Align argument pointer.
  3199.         MOVL    @(AP)+,R2             ; Move the start of the record
  3200.                                       ; description to r2.
  3201.     MOVL    (R2)+,SIZE            ; First input p[arameter is the size
  3202.                                       ; of the record to write.
  3203.     MOVL    (R2)+,FROMSTART       ; Secon input is the start address of the
  3204.                                       ; record to write.
  3205.     MOVL    @(AP)+,TOSTART        ; Third is the address to start loading
  3206.                                       ; the message buffer.
  3207.     CALLG    TRANSPARAMS,TRANSFER  ; Do the data transfer.
  3208.     RET
  3209.  
  3210.  
  3211.      
  3212.  
  3213.  
  3214. ;------------------------------------------------------------------------------
  3215. ;
  3216. ; Function        :        * Move the size and start address of the record in
  3217. ;                            ada store along with the addres in the message
  3218. ;                            buffer to transfger from to the transfer parameters
  3219. ;                          * Transfer the record to the ada record from the
  3220. ;                            message buffer.
  3221. ;
  3222. ; Input arguments :        1.) The address of the record description in ada 
  3223. ;                              space.
  3224. ;                          2.) The address to transfer from in the message
  3225. ;                              buffer.
  3226. ;
  3227. ; Output arguments: None.
  3228. ;
  3229. ; Globals Used    : The transfer parameters used as argument list for transfer
  3230. ;
  3231. ; Calls To        : TRANSFER
  3232. ;
  3233. ; Called By       : RECREAD
  3234. ;
  3235. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  3236. ;
  3237. ; Amendments      :                        (  /  /  )
  3238. ;
  3239. ; Notes           : 
  3240. ;
  3241. ;------------------------------------------------------------------------------
  3242.  
  3243.  
  3244.     .ENTRY    MTOAREC,^M<R2,R4>
  3245.         MOVL    (AP)+,DUMMY           ; Align the argument pointer.
  3246.     MOVL    @(AP)+,R2             ; Move the address of the record
  3247.                                       ; description to r2.
  3248.     MOVL    (R2)+,SIZE            ; Move the size of the record to SIZE.
  3249.     MOVL    (R2)+,TOSTART         ; The start address of the record is
  3250.                                       ; where we are going to transfer data to.
  3251.     MOVL    @(AP)+,FROMSTART      ; Move the address of the start of the
  3252.                                       ; record in the message buffer.
  3253.     CALLG    TRANSPARAMS,TRANSFER  ; Transdfer the data.
  3254.     RET
  3255.  
  3256.  
  3257.  
  3258.  
  3259. ;------------------------------------------------------------------------------
  3260. ;
  3261. ; Function        :        * Transfer the channel number to MESSAGEPIPE.
  3262. ;                          * Using MESSAGEPIPE as the channel number send a 
  3263. ;                            message to user call lib.
  3264. ;                          * Receive a reply from user call lib.
  3265. ;
  3266. ; Input arguments : None.
  3267. ;
  3268. ; Output arguments: None.
  3269. ;
  3270. ; Globals Used    : P3(R8) is the channel number passed by the syscall function
  3271. ;                   MESSAGE is the buffer filled.
  3272. ;
  3273. ; Calls To        : System services $QIOW
  3274. ;
  3275. ; Called By       : SIMPLE , RECREAD , RECWRITE
  3276. ;
  3277. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  3278. ;
  3279. ; Amendments      :                        (  /  /  )
  3280. ;
  3281. ; Notes           : 
  3282. ;
  3283. ;------------------------------------------------------------------------------
  3284.  
  3285.  
  3286.         .ENTRY    RAPCOMS,^M<R4,R5>
  3287.         CMPL    WHAT(R8),#1
  3288.         BEQL    COM
  3289.     MOVW    P3(R8),MESSAGEPIPE        ; Move the number of the channel
  3290.                                           ; from the function space.
  3291. COM:    $QIOW_S FUNC=#IO$_WRITEVBLK,-     ; Give the message to user call lib.
  3292.          CHAN=MESSAGEPIPE,-
  3293.                 P1=MESSAGE,-
  3294.                 P2=#200
  3295.         $QIOW_S FUNC=#IO$_READVBLK,-      ; Read the replyt from user call lib
  3296.                 CHAN=MESSAGEPIPE,-
  3297.                 P1=MESSAGE,-
  3298.                 P2=#200
  3299.         RET
  3300.  
  3301.  
  3302.  
  3303. ;------------------------------------------------------------------------------
  3304. ;
  3305. ; Function        :    * Move the parameters so that:=-
  3306. ;                             - R2 = The from start.
  3307. ;                             - R3 = The to start.
  3308. ;                             - R4 = The number of words to move.
  3309. ;                      * Move R4 words from R2 to R3.
  3310. ;                      * Place the end addresses in the retrun parameters.   
  3311. ;
  3312. ; Input arguments :    1.) The from address.
  3313. ;                      2.) The size.
  3314. ;                      3.) The to address.
  3315. ;
  3316. ; Output arguments:    1.) The end address of the from area.
  3317. ;                      2.) The end address of the to area.
  3318. ;
  3319. ; Globals Used    : None.
  3320. ;
  3321. ; Calls To        : None.
  3322. ;
  3323. ; Called By       : ADATOMSG , ATOMREC , MTOAREC
  3324. ;
  3325. ; Author          : M.D.DICK               (30/1/85)     Version 1.0
  3326. ;
  3327. ; Amendments      :                        (  /  /  )
  3328. ;
  3329. ; Notes           : 
  3330. ;
  3331. ;------------------------------------------------------------------------------
  3332.  
  3333.  
  3334.  
  3335.         .ENTRY    TRANSFER,^M<R2,R3,R4>
  3336.         MOVL    (AP)+,DUMMY         ; Align argument pointer.
  3337.     MOVL    @(AP)+,R2           ; Start
  3338.     MOVL    @(AP)+,R3           ; Size
  3339.     MOVL    @(AP)+,R4           ; To
  3340.     ADDL2    R2,R4               ; R3=Last Address = Start+Size .
  3341. LOOP:    CMPL    R2,R4               ; If the From=Last Address Then
  3342.     BEQL    FINIS               ; Finished
  3343.     MOVW    (R2)+,(R3)+         ; Otherwise transfer a word
  3344.     JMP    LOOP
  3345. FINIS:    MOVL    R2,@(AP)+           ; Move the final addresses to the output
  3346.     MOVL    R3,@(AP)+           ; parameters.
  3347.     RET
  3348.  
  3349.  
  3350.  
  3351.    
  3352.  
  3353. QUIT:   MOVL    R0,ERRNO(R8)        ; Return status
  3354.     CLRL    R1                      ; OK IOresult
  3355.         BLBS    R0,QUIT2                ; Its even true
  3356.         MOVL    #BADIO,R1               ; set ROS I/O result
  3357.  
  3358. QUIT2:    POPR    #^M<R2,R3,R4,R5,R6,R7,R8,R9,R10>    ; Restore registers
  3359.         MOVAL   USRDRVRT,R0             ; get ready for NEXTIOQ
  3360.         JSB     NEXTIOQ                 ; put task on readyqueue
  3361.         BEQL    10$                     ; if no more, get out
  3362.         BRW     USRSTART                ; else do next one
  3363. 10$:    RSB
  3364.  
  3365.  
  3366.  
  3367.  
  3368.  
  3369.  
  3370. USRCLR::        ;--------- clear code -----------
  3371.         MOVL    #CANCEL,IORSLTX(R6)     ; Report cancelled I/O
  3372.         RSB
  3373.         
  3374. USRCNTRL::      ;--------- control code ---------
  3375.         RSB                             ; Not implemented
  3376.  
  3377.     .END
  3378. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  3379. --R8LIB.TXT
  3380. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  3381. ------------------------------------------------------------------------
  3382. ------------------------------------------------------------------------
  3383. --                                                                    --
  3384. -- This package contains the full set of R8 routines.These act as the --
  3385. -- ADA end of the interface between the high level database access    --
  3386. -- routines (FETCH , INSERT , TRANSACT , .. ) and their equivalent    --
  3387. -- decompositions in rapport (R0FECH,R0INRT , .. ).                   --
  3388. --                                                                    --
  3389. -- All of the procedures are of the same basic type.This basic        --
  3390. -- structure can be defined as follows:-                              --
  3391. --                                                                    --
  3392. --          * A declaration as a record type of the list of           --
  3393. --            parameters that need to be passed to the                --
  3394. --            equivalent R0 routine.Variable length records are       --
  3395. --            expressed in terms of the size (in bytes) and the       --
  3396. --            start position in ADA address space.From this           --
  3397. --            information the macro message handler can find and      --
  3398. --            transfer this message to the message buffer.            --
  3399. --                                                                    --
  3400. --          * The start address and size of this record is            --
  3401. --            record is calculated so that the macro message          --
  3402. --            handler can find the parameters.                        --
  3403. --                                                                    --
  3404. --          * The neccesary IN parameters are placed into the         --
  3405. --            parameter record.                                       --
  3406. --                                                                    --
  3407. --          * The function syscall is called with parameters:-        --
  3408. --                   1.)The start addres of the record.               --
  3409. --                   2.)The size of the record.                       --
  3410. --                   3.)The channel number of the mailbox.            --
  3411. --                                                                    --
  3412. --          * The OUT parameters are copied from the parameter        --
  3413. --            record into the actual parameters.                      --
  3414. --                                                                    --
  3415. --  The only exception to this is on StartRapport where R8STAR calls  --
  3416. --  syscall with only two parameters ( as there is as yet no channel  --
  3417. --  number) and the assigned channel number is determined through the --
  3418. --  return value of the syscall function.                             --
  3419. --                                                                    --
  3420. ------------------------------------------------------------------------
  3421. ------------------------------------------------------------------------
  3422.  
  3423.  
  3424.  
  3425.  
  3426.  
  3427.  
  3428. with vms_call , unchecked_conversion , system  ; use vms_call ;
  3429.  
  3430. package r8lib is
  3431.  
  3432.  
  3433.  
  3434.  
  3435.  
  3436. procedure R8STAR ( CheckSum : in long_integer ;
  3437.                    LastFile : in long_integer ;
  3438.                    UserTaskNumber : out long_integer ;
  3439.                    ErrorCode : out long_integer ;
  3440.                    Channel : out long_integer ) ;  
  3441.  
  3442.  
  3443.  
  3444.  
  3445.  
  3446.  
  3447. procedure R8ENDR ( ErrorCode : out long_integer ;
  3448.                    Channel : in long_integer ) ;
  3449.  
  3450.  
  3451.  
  3452.  
  3453. procedure R8TRAN ( TransactionNumber : out long_integer ;
  3454.                    ErrorCode : out long_integer ;
  3455.                    Channel : in long_integer ) ;
  3456.  
  3457.  
  3458.  
  3459.  
  3460.  
  3461. procedure R8COMT ( ErrorCode : out long_integer ;
  3462.                    Channel : in long_integer ) ;
  3463.  
  3464.  
  3465.  
  3466.  
  3467.  
  3468.  
  3469. procedure R8BKTK ( ErrorCode : out long_integer ;
  3470.                    Channel : in long_integer ) ;
  3471.  
  3472.  
  3473.  
  3474.  
  3475.  
  3476.  
  3477. procedure R8INRT ( FileNumber : in long_integer ;
  3478.            SizeOfRecord : in long_integer ;
  3479.                    StartOfRecord : in long_integer ;
  3480.                    ErrorCode : out long_integer ;
  3481.                    channel : in long_integer ) ;
  3482.  
  3483.  
  3484.  
  3485.  
  3486.  
  3487.  
  3488.  
  3489. procedure R8UPDT ( FileNumber : in long_integer ;
  3490.                    SizeOfRecord : in long_integer ;
  3491.                    StartOfRecord : in long_integer ;
  3492.                    ErrorCode : out long_integer ;
  3493.                    Channel : in long_integer ) ;
  3494.  
  3495.  
  3496.  
  3497.  
  3498.  
  3499.  
  3500.  
  3501.  
  3502. procedure R8STOR ( FileNumber : in long_integer ;
  3503.                    SizeOfRecord : in long_integer ;
  3504.                    StartOfRecord : in long_integer ;
  3505.                    ErrorCode : out long_integer ;
  3506.                    Channel : in long_integer ) ;
  3507.  
  3508.  
  3509.  
  3510.  
  3511.  
  3512.  
  3513.  
  3514.  
  3515. procedure R8COND  ( FileNumber : in long_integer ;
  3516.             ConditionNumber : in long_integer ;
  3517.             FieldNumber : in long_integer ;
  3518.             AnyAllSwitch : in long_integer ;
  3519.             SubscriptValue : in long_integer ;
  3520.             RelationNumber : in long_integer ;
  3521.             ConjunctionNumber : in long_integer ;
  3522.                     SizeOfRHS : in long_integer ;
  3523.                     StartOfRHS : in long_integer ;
  3524.                     Channel : in long_integer ) ;
  3525.  
  3526.  
  3527.  
  3528.  
  3529.  
  3530.  
  3531. procedure R8FECH ( FileNumber : in long_integer ;
  3532.                    CountVariable : in out long_integer ;
  3533.                    RetrievalStrategy : in out long_integer ;
  3534.                    NumberOfConditions : in long_integer ;
  3535.                    Level : in long_integer ;
  3536.                    SizeOfRecord : in long_integer ;
  3537.                    StartOfRecord : in long_integer ;
  3538.                    Channel : in long_integer ) ;
  3539.  
  3540.  
  3541.  
  3542.  
  3543.  
  3544.  
  3545. procedure R8DELT ( FileNumber : in long_integer ;
  3546.                    CountVariable : in out long_integer ;
  3547.                    NumberOfConditions : in long_integer ;
  3548.                    channel : in long_integer ) ;
  3549.  
  3550.  
  3551.  
  3552.  
  3553.  
  3554.  
  3555.  
  3556.  
  3557. procedure R8STKY ( FileNumber : in long_integer ;
  3558.                    NumberOfFields : in long_integer ;
  3559.                    StartOfSortKeyArray : in long_integer ;
  3560.                    TypeOfRetrieval : in long_integer ;
  3561.                    Channel : in long_integer ) ;
  3562.  
  3563.  
  3564.  
  3565.  
  3566.  
  3567.  
  3568.  
  3569. procedure R8HOLD ( FileNumber : in long_integer ;
  3570.                    NumberOfConditions : in long_integer ;
  3571.                    NumberOfRecords : out long_integer ;
  3572.                    Channel : in long_integer ) ;
  3573.  
  3574.  
  3575.  
  3576.  
  3577.  
  3578.  
  3579.  
  3580. procedure R8ENRV ( CountVariable : in long_integer ;
  3581.                    ErrorCode : out long_integer ;
  3582.                    Channel : in long_integer ) ;
  3583.  
  3584.  
  3585.  
  3586.  
  3587.  
  3588.  
  3589.  
  3590. procedure R8RTRV ( FileNumber : in long_integer ;
  3591.                    CountVariable : in out long_integer ;
  3592.                    SizeOfRecord : in long_integer ;
  3593.                    StartOfRecord : in long_integer ;
  3594.                    Channel : in long_integer ) ;
  3595.  
  3596.  
  3597.  
  3598.  
  3599.  
  3600.  
  3601.  
  3602. procedure R8CLFI ( FileNumber : in long_integer ;
  3603.                    ErrorCode : out long_integer ;
  3604.                    Channel : in long_integer ) ;
  3605.  
  3606.  
  3607.  
  3608.  
  3609.  
  3610. procedure R8LOCK ( FileNumber : in long_integer ;
  3611.                    ReadWriteSwitch : in long_integer ;
  3612.                    ErrorCode : out long_integer ;
  3613.                    Channel : in long_integer ) ;
  3614.  
  3615.  
  3616.  
  3617.  
  3618.  
  3619.  
  3620. end R8LIB ;
  3621.  
  3622.  
  3623.  
  3624.  
  3625.  
  3626. package body R8LIB is
  3627.  
  3628.  
  3629. -- Package specific data used in creation of the parameter record
  3630.  
  3631. NumberOfBytesOfRecordDescription : constant integer:=8 ;
  3632.  
  3633. NumberOfBitsInAByte : constant integer:=8  ;
  3634.  
  3635.  
  3636.  
  3637.  
  3638. -- this takes as input an address and returns a long_integer . Used in 
  3639. -- converting the address of a parameter record to understandable 
  3640. -- long integer form .
  3641.  
  3642. function AddressToLongInteger is new Unchecked_Conversion(System.address ,
  3643.                                                           long_integer ) ;
  3644.  
  3645.    
  3646.  
  3647.  
  3648.  
  3649.  
  3650. procedure R8STAR ( CheckSum : in long_integer ;
  3651.                    LastFile : in long_integer ;
  3652.                    UserTaskNumber : out long_integer ;
  3653.                    ErrorCode : out long_integer ;
  3654.                    Channel : out long_integer ) is
  3655.  
  3656. -------------------------------------------------------------------------------
  3657. --
  3658. -- Function        : Acts as the user interface to the rapport R0STAR which
  3659. --                   starts communication with the rapport nucleus. 
  3660. --
  3661. -- Input arguments : CheckSum:- A value introduced by MakePackage as a
  3662. --                              check on the ddf of the named file.
  3663. --                   LastFile:- A number indicating the last file refrenced
  3664. --                              in the DDF .
  3665. --
  3666. -- Output arguments: UserTaskNumber:-A number returned to the task by the 
  3667. --                                   nucleus which uniquely identifies the task
  3668. --                   ErrorCode:-Returned as an indicator of the success of
  3669. --                              the execution of R0STAR.A value <-1 indicates
  3670. --                              indicates that a serious error has been 
  3671. --                              detected in the execution. 
  3672. --                   Channel:-The returned channel code to the set-up mailbox
  3673. --                            to user call lib.
  3674. --
  3675. -- Globals Accessed: NumberOfBitsInAByte .
  3676. --
  3677. -- Calls to        : vms_call.syscall2 , AddressToLongInteger .
  3678. --
  3679. -- Called by       : PerFile.StartRapport
  3680. --
  3681. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  3682. --
  3683. -- Amendments      :                        (  /  /  )
  3684. --
  3685. -- Notes           : 
  3686. --
  3687. -------------------------------------------------------------------------------
  3688.  
  3689.  
  3690.  
  3691. type StartRapportParameters is
  3692.  
  3693.      record
  3694.  
  3695.        ErrorCode : long_integer ;
  3696.        CheckSum : long_integer ;
  3697.        UserTaskNumber : long_integer ;
  3698.        LastFile : long_integer ;
  3699.  
  3700.      end record ;
  3701.  
  3702.  
  3703. StartRapportRequest : long_integer:=1 ;
  3704.  
  3705. Params : StartRapportParameters ; 
  3706.  
  3707. ParamsSize : long_integer ;
  3708.  
  3709. ParamsStart : long_integer ;
  3710.  
  3711.  
  3712. begin
  3713.  
  3714.   -- parameters INTO the record .
  3715.  
  3716.   Params.CheckSum:=CheckSum ;
  3717.   Params.LastFile:=LastFile ;
  3718.   ParamsSize:=long_integer(StartRapportParameters'Size/NumberOfBitsInAByte) ;
  3719.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  3720.  
  3721.   -- transmit to RAPPORT .
  3722.  
  3723.   Channel:=syscall2(StartRapportRequest , ParamsStart, ParamsSize ) ;
  3724.  
  3725.   -- parameters OUT OF record .
  3726.  
  3727.   ErrorCode:=Params.ErrorCode ;
  3728.   UserTaskNumber:=Params.UserTaskNumber ;
  3729.  
  3730. end ;
  3731.  
  3732.  
  3733.  
  3734.  
  3735.  
  3736. procedure R8ENDR ( ErrorCode : out long_integer ;
  3737.                    Channel : in long_integer ) is
  3738.  
  3739. -------------------------------------------------------------------------------
  3740. --
  3741. -- Function        : User interface to the rapport R0ENDR.Cuts off 
  3742. --                   communication with the connected nucleus.
  3743. --
  3744. -- Input arguments : Channel:-Number of the mail box connecting to user call 
  3745. --                            lib. 
  3746. --
  3747. -- Output arguments: ErrorCode:- Indication as to the success in executing
  3748. --                               R0ENDR.An ErrorCode <-1 is an indication
  3749. --                               that a serious error has occurred.
  3750. --
  3751. -- Global variables: NumberOfBitsInAByte . 
  3752. --
  3753. -- Calls to        : vms_call.syscall3
  3754. --
  3755. -- Called by       : PerFile.EndRapport
  3756. --
  3757. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  3758. --
  3759. -- Amendments      :                        (  /  /  )
  3760. --
  3761. -- Notes           : 
  3762. --
  3763. -------------------------------------------------------------------------------
  3764.  
  3765.  
  3766. type EndRapportParameters is
  3767.  
  3768.      record
  3769.  
  3770.        ErrorCode : long_integer ;
  3771.  
  3772.      end record ;
  3773.  
  3774.  
  3775. EndRapportRequest : long_integer:=2 ;
  3776.  
  3777. Params : EndRapportParameters ;
  3778.  
  3779. ParamsSize : long_integer ;
  3780.  
  3781. ParamsStart : long_integer ;
  3782.  
  3783. DummyReturn : long_integer ;
  3784.  
  3785.  
  3786.  
  3787. begin
  3788.  
  3789.   -- Parameters INTO the record
  3790.  
  3791.   ParamsSize:=long_integer(EndRapportParameters'Size/NumberOfBitsInAByte) ;
  3792.   ParamsStart:=AddressToLongInteger(Params'Address) ;   
  3793.  
  3794.   -- transmit to RAPPORT
  3795.  
  3796.   DummyReturn:=syscall3(EndRapportRequest,ParamsStart,ParamsSize,Channel ) ;
  3797.  
  3798.   -- parameters OUT OF record
  3799.  
  3800.   ErrorCode:=Params.ErrorCode ;
  3801.  
  3802.  
  3803. end ;
  3804.  
  3805.  
  3806.  
  3807.  
  3808. procedure R8TRAN ( TransactionNumber : out long_integer ;
  3809.                    ErrorCode : out long_integer ;
  3810.                    Channel : in long_integer ) is
  3811.  
  3812.  
  3813. -------------------------------------------------------------------------------
  3814. --
  3815. -- Function        : User interface to the rapport R0TRAN.Starts a databse 
  3816. --                   transaction.
  3817. --
  3818. -- Input arguments : Channel:-The channel number to the mailbox connecting to
  3819. --                   user call lib.
  3820. --
  3821. -- Output arguments: TransactionNumber:- An identifier given by the nucleus
  3822. --                                       to identify the transaction.
  3823. --                 ErrorCode:- An indication as to the success of the 
  3824. --                 execution of R0TRANS.An errorCode < -1
  3825. --                 indicates that a serious error has occurred.
  3826. --
  3827. -- Global variables: NumberOfBitsInAByte..
  3828. --
  3829. -- Calls to        : vms_call.syscall3
  3830. --
  3831. -- Called by       : PerFile.Transact
  3832. --
  3833. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  3834. --
  3835. -- Amendments      :                        (  /  /  )
  3836. --
  3837. -- Notes           : 
  3838. --
  3839. -------------------------------------------------------------------------------
  3840.  
  3841.  
  3842.  
  3843. type TransactionParameters is
  3844.  
  3845.      record
  3846.  
  3847.        ErrorCode : long_integer ;
  3848.        TransactionNumber : long_integer ;
  3849.  
  3850.      end record ;
  3851.  
  3852.  
  3853. TransactionRequest : long_integer:=3 ;
  3854.  
  3855. Params : TransactionParameters ;
  3856.  
  3857. ParamsSize : long_integer ;
  3858.  
  3859. ParamsStart : long_integer ;
  3860.  
  3861. DummyReturn : long_integer ;
  3862.  
  3863.  
  3864. begin
  3865.  
  3866.   -- parameters INTO record .
  3867.  
  3868.   ParamsSize:=long_integer(TransactionParameters'Size/NumberOfBitsInAByte) ;
  3869.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  3870.  
  3871.   -- transmit to RAPPORT .
  3872.  
  3873.   DummyReturn:=syscall3(TransactionRequest,ParamsStart,ParamsSize,Channel) ;
  3874.  
  3875.   -- parameters OUT OF record .
  3876.  
  3877.   TransactionNumber:=Params.TransactionNumber ;
  3878.   ErrorCode:=Params.ErrorCode ;
  3879.  
  3880. end ;
  3881.  
  3882.  
  3883.  
  3884.  
  3885.  
  3886.  
  3887. procedure R8COMT ( ErrorCode : out long_integer ;
  3888.                    Channel : in long_integer ) is
  3889.  
  3890.  
  3891. -------------------------------------------------------------------------------
  3892. --
  3893. -- Function        : User interface to the rapport R0COMT. 
  3894. --
  3895. -- Input arguments : Channel:-Number of the channel to the mailbox connecting
  3896. --                  to user call lib.
  3897. --
  3898. -- Output arguments: ErrorCode:- An indication as to the success of the 
  3899. --                 execution of R0COMT.Error code < -1
  3900. --                               indicates that a serious error has occurred.
  3901. --
  3902. -- Global variables: NumberOfBitsInAByte
  3903. --
  3904. -- Calls to        : vms_call.syscall3
  3905. --
  3906. -- Called by       : PerFile.Commit
  3907. --
  3908. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  3909. --
  3910. -- Amendments      :                        (  /  /  )
  3911. --
  3912. -- Notes           : 
  3913. --
  3914. -------------------------------------------------------------------------------
  3915.  
  3916.  
  3917.  
  3918. type CommitParameters is
  3919.  
  3920.      record
  3921.  
  3922.        ErrorCode : long_integer ;
  3923.  
  3924.      end record ;
  3925.  
  3926.  
  3927. CommitRequest : long_integer:=4 ;
  3928.  
  3929. Params : CommitParameters ;
  3930.  
  3931. ParamsSize : long_integer ;
  3932.  
  3933. ParamsStart : long_integer ;
  3934.  
  3935. DummyReturn : long_integer ;
  3936.  
  3937.  
  3938.  
  3939. begin
  3940.  
  3941.   -- paramaters INTO record .
  3942.  
  3943.   ParamsSize:=long_integer(CommitParameters'Size/NumberOfBitsInAByte) ;
  3944.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  3945.  
  3946.   -- transmit to RAPPORT .
  3947.  
  3948.   DummyReturn:=syscall3(CommitRequest,ParamsStart,ParamsSize,Channel) ;
  3949.  
  3950.   -- parameters OUT OF record .
  3951.  
  3952.   ErrorCode:=Params.ErrorCode ;
  3953.  
  3954. end ;
  3955.  
  3956.  
  3957.  
  3958.  
  3959.  
  3960.  
  3961. procedure R8BKTK ( ErrorCode : out long_integer ;
  3962.                    Channel : in long_integer ) is
  3963.  
  3964.  
  3965.  
  3966. -------------------------------------------------------------------------------
  3967. --
  3968. -- Function        : User interface to the rapport R0BKTK. 
  3969. --
  3970. -- Input arguments : Channel :-The number of the channel of the mailbox
  3971. --                      connecting to user calll ib.
  3972. --
  3973. -- Output arguments: ErrorCode:- An indication as to the success of the 
  3974. --                 execution of R0BKTK.An error code < -1
  3975. --                               indicates that a serious error has occurred.
  3976. --
  3977. -- Global variables: NumberOfBitsInAByte
  3978. --
  3979. -- Calls to        : vms_call.syscall3
  3980. --
  3981. -- Called by       : PerFile.Backout
  3982. --
  3983. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  3984. --
  3985. -- Amendments      :                        (  /  /  )
  3986. --
  3987. -- Notes           : 
  3988. --
  3989. -------------------------------------------------------------------------------
  3990.  
  3991.  
  3992.  
  3993. type BackoutParameters is
  3994.  
  3995.      record
  3996.  
  3997.        ErrorCode : long_integer ;
  3998.  
  3999.      end record ;
  4000.  
  4001.  
  4002. BackoutRequest : long_integer:=5 ;
  4003.  
  4004. Params : BackoutParameters ;
  4005.  
  4006. ParamsSize : long_integer ;
  4007.  
  4008. ParamsStart : long_integer ;
  4009.  
  4010. DummyReturn : long_integer ;
  4011.  
  4012.  
  4013. begin
  4014.  
  4015.   -- parameters INTO record .
  4016.  
  4017.   ParamsSize:=long_integer(BackoutParameters'Size/NumberOfBitsInAByte) ;
  4018.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  4019.  
  4020.   -- transmit to RAPPORT .
  4021.  
  4022.   DummyReturn:=syscall3(BackoutRequest,ParamsStart,ParamsSize,Channel) ;
  4023.  
  4024.   -- parameters OUT OF record .
  4025.  
  4026.   ErrorCode:=Params.ErrorCode ;
  4027.  
  4028. end ;
  4029.  
  4030.  
  4031.  
  4032.  
  4033.  
  4034.  
  4035.  
  4036. procedure R8INRT ( FileNumber : in long_integer ;
  4037.            SizeOfRecord : in long_integer ;
  4038.                    StartOfRecord : in long_integer ;
  4039.                    ErrorCode : out long_integer ;
  4040.                    channel : in long_integer ) is
  4041.  
  4042.  
  4043.  
  4044. -------------------------------------------------------------------------------
  4045. --
  4046. -- Function        : User interface to the rapport R0INRT.To insert a record
  4047. --             into a file.
  4048. --
  4049. -- Input arguments : FileNumber:- File number of the file to insert the record
  4050. --                                into.
  4051. --                   SizeOfRecord:- The size of the record to insert in words.
  4052. --                   StartOfRecord:- The address in ADA space of the record.
  4053. --             Channel:-The number of the channel of the mailbox
  4054. --                  connecting to the user calll ib.
  4055. --
  4056. -- Output arguments: ErrorCode:- An indication as to the success of the 
  4057. --                               execution of R0INRT.An error code < -1
  4058. --                               indicates thatt a serious error has occurred.
  4059. --
  4060. -- Global variables: NumberOfBitsInAByte , NumberOfBytesOfRecordDescription .
  4061. --
  4062. -- Calls to        : vms_call.syscall3
  4063. --
  4064. -- Called by       : PerFile.Insert
  4065. --
  4066. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  4067. --
  4068. -- Amendments      :                        (  /  /  )
  4069. --
  4070. -- Notes           : 
  4071. --
  4072. -------------------------------------------------------------------------------
  4073.  
  4074.  
  4075. type InsertParameters is
  4076.  
  4077.      record
  4078.  
  4079.        ErrorCode : long_integer ;
  4080.        FileNumber : long_integer ;
  4081.        SizeOfRecord : long_integer ;
  4082.        StartOfRecord : long_integer ;
  4083.  
  4084.      end record ;
  4085.  
  4086.  
  4087. InsertRequest : long_integer:=6 ;
  4088.  
  4089. Params : InsertParameters ;
  4090.  
  4091. ParamsSize : long_integer ;
  4092.  
  4093. ParamsStart : long_integer ;
  4094.  
  4095. DummyReturn : long_integer ;
  4096.  
  4097.  
  4098. begin
  4099.  
  4100.   -- parameters INTO the record .
  4101.  
  4102.      -- notice that the size of the record is modified by the number of
  4103.      -- bytes of the record that contain information about the record to
  4104.      -- insert . ParamsSize is the size of trhe parameters to be transmitted 
  4105.      -- to RAPPORT .
  4106.  
  4107.   ParamsSize:=long_integer((InsertParameters'Size/NumberOfBitsInAByte)
  4108.                             - NumberOfBytesOfRecordDescription ) ;
  4109.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  4110.   Params.FileNumber:=FileNumber ;
  4111.   Params.SizeOfREcord:=SizeOfRecord ;
  4112.   Params.StartOfREcord:=StartOfRecord ;
  4113.  
  4114.   -- transmit to RAPPORT .
  4115.  
  4116.   DummyReturn:=syscall3(InsertRequest,ParamsStart,ParamsSize,Channel) ;
  4117.  
  4118.   -- parameters OUT OF record .
  4119.  
  4120.   ErrorCode:=Params.ErrorCode ;
  4121.  
  4122. end ;
  4123.  
  4124.  
  4125.  
  4126.  
  4127.  
  4128.  
  4129.  
  4130.  
  4131. procedure R8UPDT ( FileNumber : in long_integer ;
  4132.                    SizeOfRecord : in long_integer ;
  4133.                    StartOfRecord : in long_integer ;
  4134.                    ErrorCode : out long_integer ;
  4135.                    Channel : in long_integer ) is
  4136.  
  4137.  
  4138. -------------------------------------------------------------------------------
  4139. --
  4140. -- Function        : User interface to the rapport R0UPDT.To update a record
  4141. --             in a file.
  4142. --
  4143. -- Input arguments : FileNumber:- File number of the file to update the record
  4144. --                                into.
  4145. --                   SizeOfRecord:- The size of the record to update in words.
  4146. --                   StartOfRecord:- The address in ADA space of the record.
  4147. --             Channel:-The channel number of the mailbox connecting
  4148. --                  to user call lib.
  4149. --
  4150. -- Output arguments: ErrorCode:- An indication as to the success of the 
  4151. --                               execution of R0UPDT.An error code < -1
  4152. --                               indicates thatt a serious error has occurred.
  4153. --
  4154. -- Global variables: NumberOfBitsInAByte , NumberOfBytesOfRecorddescription .
  4155. --
  4156. -- Calls to        : vms_call.syscall3
  4157. --
  4158. -- Called by       : PerFile.Update
  4159. --
  4160. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  4161. --
  4162. -- Amendments      :                        (  /  /  )
  4163. --
  4164. -- Notes           : 
  4165. --
  4166. -------------------------------------------------------------------------------
  4167.  
  4168. type UpdateParameters is
  4169.  
  4170.      record
  4171.  
  4172.        ErrorCode : long_integer ;
  4173.        FileNumber : long_integer ;
  4174.        SizeOfRecord : long_integer ;
  4175.        StartOfRecord : long_integer ;
  4176.  
  4177.      end record ;
  4178.  
  4179.  
  4180. UpdateRequest : long_integer:=7 ;
  4181.  
  4182. Params : UpdateParameters ;
  4183.  
  4184. ParamsSize : long_integer ;
  4185.  
  4186. ParamsStart : long_integer ;
  4187.  
  4188. DummyReturn : long_integer ;
  4189.  
  4190.  
  4191. begin
  4192.  
  4193.   -- parameters INTO the record .
  4194.  
  4195.      -- notice that the size of the record is modified by the number of
  4196.      -- bytes of the record that contain information about the record to
  4197.      -- insert . ParamsSize is the size of trhe parameters to be transmitted 
  4198.      -- to RAPPORT .
  4199.  
  4200.  
  4201.   ParamsSize:=long_integer((UpdateParameters'Size/NumberOfBitsInAByte)
  4202.                            - NumberOfBytesOfRecordDescription ) ;
  4203.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  4204.   Params.FileNumber:=FileNumber ;
  4205.   Params.SizeOfRecord:=SizeOfRecord ;
  4206.   Params.StartOfRecord:=StartOfRecord ;
  4207.  
  4208.   -- transmit to RAPPORT .
  4209.  
  4210.   DummyReturn:=syscall3(UpdateRequest,ParamsStart,ParamsSize,Channel) ;
  4211.  
  4212.   -- parameters OUt OF record .
  4213.  
  4214.   ErrorCode:=Params.ErrorCode ;
  4215.  
  4216.  
  4217. end ;
  4218.  
  4219.  
  4220.  
  4221.  
  4222.  
  4223.  
  4224.  
  4225. procedure R8STOR ( FileNumber : in long_integer ;
  4226.                    SizeOfRecord : in long_integer ;
  4227.                    StartOfRecord : in long_integer ;
  4228.                    ErrorCode : out long_integer ;
  4229.                    Channel : in long_integer ) is
  4230.  
  4231.  
  4232.  
  4233.  
  4234. -------------------------------------------------------------------------------
  4235. --
  4236. -- Function        : User interface to the rapport R0STOR.To store a record
  4237. --             in a file.
  4238. --
  4239. -- Input arguments : FileNumber:- File number of the file to store the record
  4240. --                                in.
  4241. --                   SizeOfRecord:- The size of the record to store in words.
  4242. --                   StartOfRecord:- The address in ADA space of the record.
  4243. --                   Channel:-The number of the channel of the mailbox
  4244. --                  connecting to user call lib.
  4245. --
  4246. -- Output arguments: ErrorCode:- An indication as to the success of the 
  4247. --                               execution of R0STOR.An error code < -1
  4248. --                               indicates thatt a serious error has occurred.
  4249. --
  4250. -- Global variables: NumberOfBitsInAByte , NumberOfBytesOfRecorddescription .
  4251. --
  4252. -- Calls to        : vms_call.syscall3
  4253. --
  4254. -- Called by       : PerFile.Store
  4255. --
  4256. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  4257. --
  4258. -- Amendments      :                        (  /  /  )
  4259. --
  4260. -- Notes           : 
  4261. --
  4262. -------------------------------------------------------------------------------
  4263.  
  4264.  
  4265. type StoreParameters is
  4266.  
  4267.      record
  4268.   
  4269.        ErrorCode : long_integer ;
  4270.        FileNumber : long_integer ;
  4271.        SizeOfRecord : long_integer ;
  4272.        StartOfRecord : long_integer ;
  4273.  
  4274.      end record ;
  4275.  
  4276.  
  4277. StoreRequest : long_integer:=8;
  4278.  
  4279. Params : StoreParameters ;
  4280.  
  4281. ParamsSize : long_integer ;
  4282.  
  4283. ParamsStart : long_integer ;
  4284.  
  4285. DummyReturn : long_integer ;
  4286.  
  4287.  
  4288. begin
  4289.  
  4290.   -- parameters INTO the record .
  4291.  
  4292.      -- notice that the size of the record is modified by the number of
  4293.      -- bytes of the record that contain information about the record to
  4294.      -- insert . ParamsSize is the size of trhe parameters to be transmitted 
  4295.      -- to RAPPORT .
  4296.  
  4297.   ParamsSize:=long_integer((StoreParameters'Size/NumberOfBitsInAByte)
  4298.                            - NumberOfBytesOfRecordDescription ) ;
  4299.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  4300.   Params.FileNumber:=FileNumber ;
  4301.   Params.SizeOfRecord:=SizeOfRecord ;
  4302.   Params.StartOfRecord:=StartOfRecord ;
  4303.  
  4304.   -- transmit to RAPPORT .
  4305.  
  4306.   DummyReturn:=syscall3(StoreRequest,ParamsStart,ParamsSize,Channel) ;
  4307.  
  4308.   -- parameters OUT OF record .
  4309.  
  4310.   ErrorCode:=Params.ErrorCode ;
  4311.  
  4312.  
  4313. end ;
  4314.  
  4315.  
  4316.  
  4317.  
  4318.  
  4319.  
  4320.  
  4321. procedure R8COND  ( FileNumber : in long_integer ;
  4322.             ConditionNumber : in long_integer ;
  4323.             FieldNumber : in long_integer ;
  4324.             AnyAllSwitch : in long_integer ;
  4325.             SubscriptValue : in long_integer ;
  4326.             RelationNumber : in long_integer ;
  4327.             ConjunctionNumber : in long_integer ;
  4328.                     SizeOfRHS : in long_integer ;
  4329.                     StartOfRHS : in long_integer ;
  4330.                     Channel : in long_integer ) is
  4331.  
  4332.  
  4333. -------------------------------------------------------------------------------
  4334. --
  4335. -- Function        : User interface to the rapport R0COND.To place a condition
  4336. --                   on a file that will be used in a subsequent search or
  4337. --             or delete. 
  4338. --
  4339. -- Input arguments : Filenumber:- The number of the file that the condition 
  4340. --                  is on.
  4341. --             ConditionNumber:- The number of this particular call in
  4342. --                           the set of calls. 
  4343. --             FieldNumber:-The number of the field on the LHS of the
  4344. --                  condition.
  4345. --                   AnyAllSwitch:- An indication as to the mode of testing
  4346. --                    on an array.
  4347. --                       i.e ANY element of array > 10
  4348. --                           ALL elements of array > 10
  4349. --                   SubscriptValue:- If only one element of an array is to
  4350. --                      be tested then this indicates which one.
  4351. --                   RelationNumber:-The code number of the relation connecting
  4352. --                                   the left and right hand sides.
  4353. --                          i.e. 1  -  Equals
  4354. --                                  -
  4355. --                                             6  -  Unequal
  4356. --             ConjunctionNumber:-The number of the conjunction
  4357. --                            assosciated with the relation.The
  4358. --                        number is modified to indicate the 
  4359. --                        level in the whole condition that the 
  4360. --                    particular conjuction occurs at.
  4361. --                           i.e. 1 - or
  4362. --                                 2 - and
  4363. --                    Plus an offset of  10 for each level
  4364. --                                       So a value of 32 => an and conjunction
  4365. --                    at the third level.
  4366. --             Channel:-The number of the channel of the mailbox
  4367. --                  connecting to user call lib.
  4368. --
  4369. -- Output arguments: None.
  4370. --
  4371. -- Global variables: NumberOfBitsInAByte , NumberOfBytesOfRecorddescription .
  4372. --
  4373. -- Calls to        : vms_call.syscall3
  4374. --
  4375. -- Called by       : PerFile.TreeWalker
  4376. --
  4377. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  4378. --
  4379. -- Amendments      :                        (  /  /  )
  4380. --
  4381. -- Notes           : 
  4382. --
  4383. -------------------------------------------------------------------------------
  4384.  
  4385.  
  4386. type ConditionParameters is
  4387.  
  4388.      record
  4389.  
  4390.        FileNumber : long_integer ;
  4391.        ConditionNumber : long_integer ;
  4392.        FieldNumber : long_integer ;
  4393.        AnyAllSwitch : long_integer ;
  4394.        SubscriptValue : long_integer ;
  4395.        RelationNumber : long_integer ;
  4396.        ConjunctionNumber : long_integer ;
  4397.        SizeOfRHS : long_integer ;
  4398.        StartOfRHS : long_integer ;
  4399.  
  4400.      end record ;
  4401.  
  4402.  
  4403. ConditionRequest : long_integer:=9;
  4404.  
  4405. Params : ConditionParameters ;
  4406.  
  4407. ParamsSize : long_integer ;
  4408.  
  4409. ParamsStart : long_integer ;
  4410.  
  4411. DummyReturn : long_integer ;
  4412.  
  4413.  
  4414. begin
  4415.  
  4416.   -- parameters INTO the record .
  4417.  
  4418.      -- notice that the size of the record is modified by the number of
  4419.      -- bytes of the record that contain information about the record to
  4420.      -- insert . ParamsSize is the size of trhe parameters to be transmitted 
  4421.      -- to RAPPORT .
  4422.  
  4423.  
  4424.   ParamsSize:=long_integer((ConditionParameters'Size/NumberOfBitsInAByte)
  4425.                             - NumberOfBytesOfRecordDescription) ;
  4426.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  4427.   Params.FileNumber:=FileNumber ;
  4428.   Params.ConditionNumber:=ConditionNumber ;
  4429.   Params.FieldNumber:=FieldNumber ;
  4430.   Params.AnyAllSwitch:=AnyAllSwitch ;
  4431.   Params.SubscriptValue:=SubscriptValue ;
  4432.   Params.RelationNumber:=RelationNumber ;
  4433.   Params.ConjunctionNumber:=ConjunctionNumber ;
  4434.   Params.SizeOfRHS:=SizeOfRHS ;
  4435.   Params.StartOfRHS:=StartOfRHS ;
  4436.  
  4437.   -- transmit to RAPPORT
  4438.  
  4439.   DummyReturn:=syscall3(ConditionRequest,ParamsStart,ParamsSize,Channel) ;
  4440.  
  4441.  
  4442.   -- there are no returns .
  4443.  
  4444. end ;
  4445.  
  4446.  
  4447.  
  4448.  
  4449.  
  4450. procedure R8FECH ( FileNumber : in long_integer ;
  4451.                    CountVariable : in out long_integer ;
  4452.                    RetrievalStrategy : in out long_integer ;
  4453.                    NumberOfConditions : in long_integer ;
  4454.                    Level : in long_integer ;
  4455.                    SizeOfRecord : in long_integer ;
  4456.                    StartOfRecord : in long_integer ;
  4457.                    Channel : in long_integer ) is
  4458.  
  4459.  
  4460. -------------------------------------------------------------------------------
  4461. --
  4462. -- Function        : User interface to R0FECH.To fetch a record from the
  4463. --             database.
  4464. --
  4465. -- Input arguments : FileNumber:-The number of the file to fetch the record
  4466. --                 from.
  4467. --             CountVariable:-A pointer to the last record fetched.This
  4468. --                    is 0 if this is the first call of a set or
  4469. --                                  a stand alone call.
  4470. --             RetrievalStrategy:-If none is known then this is set to 0.
  4471. --                   NumberOfConditions:-The number of conditions on this 
  4472. --                         particular fetch.
  4473. --                   Level:-A rapport search loop stack pointer .
  4474. --                   SizeOfRecord:-The size of the record that is to be fetched.
  4475. --                   StartOfRecord:-The start address in ada space where the
  4476. --                    record is to be put.
  4477. --                   Channel:-The number of the channel to the mailbox
  4478. --                  connecting to user calll ib.
  4479. --
  4480. -- Output arguments: CountVariable:-A pointer to the record that has just been 
  4481. --                    fetched.On the next call to fetch (if it is
  4482. --                    one of a set in a search) will have the
  4483. --                    count variable set to this value.
  4484. --                   RetrievalStrategy:-If this was set to 0 on the call then 
  4485. --                    rapport will have decided upon a search
  4486. --                                      strategy and set RetrievalSDtrategy to
  4487. --                    indicate the choice that has been made.
  4488. --
  4489. -- Global variables: NumberOfBitsInAByte , NumberOfBytesOfRecordDescription .
  4490. --
  4491. -- Calls to        : vms_call.syscall3
  4492. --
  4493. -- Called by       : PerFile.Search
  4494. --
  4495. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  4496. --
  4497. -- Amendments      :                        (  /  /  )
  4498. --
  4499. -- Notes           : 
  4500. --
  4501. -------------------------------------------------------------------------------
  4502.  
  4503.  
  4504.  
  4505. type FetchParameters is
  4506.  
  4507.      record
  4508.  
  4509.        CountVariable : long_integer ;
  4510.        Level : long_integer ;
  4511.        FileNumber : long_integer ;
  4512.        RetrievalStrategy : long_integer ;
  4513.        NumberOfConditions : long_integer ;
  4514.        SizeOfRecord : long_integer ;
  4515.        StartOfRecord : long_integer ;
  4516.  
  4517.      end record ;
  4518.  
  4519.  
  4520. FetchRequest : long_integer:=10;
  4521.  
  4522. Params : FetchParameters ;
  4523.  
  4524. ParamsSize : long_integer ;
  4525.  
  4526. ParamsStart : long_integer ;
  4527.  
  4528. DummyReturn : long_integer ;
  4529.  
  4530.  
  4531. begin
  4532.  
  4533.   -- parameters INTO the record .
  4534.  
  4535.      -- notice that the size of the record is modified by the number of
  4536.      -- bytes of the record that contain information about the record to
  4537.      -- insert . ParamsSize is the size of trhe parameters to be transmitted 
  4538.      -- to RAPPORT .
  4539.  
  4540.  
  4541.   ParamsSize:=long_integer((FetchParameters'Size/NumberOfBitsInAByte)
  4542.                             - NumberOfBytesOfREcordDescription ) ;
  4543.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  4544.   Params.Level:=Level ;
  4545.   Params.RetrievalStrategy:=RetrievalStrategy ;
  4546.   Params.NumberOfConditions:=NumberOfConditions ;
  4547.   Params.FileNumber:=FileNumber ;
  4548.   Params.CountVariable:=CountVariable ;
  4549.   Params.SizeOfRecord:=SizeOfRecord ;
  4550.   Params.StartOfRecord:=StartOfRecord ;
  4551.  
  4552.   -- transmit to RAPPORT .
  4553.  
  4554.   DummyReturn:=syscall3(FetchRequest,ParamsStart,ParamsSize,Channel) ;
  4555.  
  4556.   -- parameters OUT OF record .
  4557.  
  4558.   CountVariable:=Params.CountVariable ;
  4559.   RetrievalStrategy:=Params.RetrievalStrategy ;
  4560.  
  4561. end ;
  4562.  
  4563.  
  4564.  
  4565.  
  4566.  
  4567. procedure R8DELT ( FileNumber : in long_integer ;
  4568.                    CountVariable : in out long_integer ;
  4569.                    NumberOfConditions : in long_integer ;
  4570.                    channel : in long_integer ) is
  4571.  
  4572.  
  4573. -------------------------------------------------------------------------------
  4574. --
  4575. -- Function        : User interface to the rapport R0DELT.To delete records
  4576. --             from the database.
  4577. --
  4578. -- Input arguments : FileNumber:-The file number of the file to delete from.
  4579. --                   CountVariable:-Indicates the number of records deleted .
  4580. --             NumberOfConditions:-The number of conditions on the delete
  4581. --                   Channel:-The number of the channel to the mailbox
  4582. --                  connecting to user call lib.
  4583. --
  4584. -- Output arguments: UserCount (?)
  4585. --
  4586. -- Global variables: NumberOfBitsInAByte.
  4587. --
  4588. -- Calls to        : vms_call.syscall3
  4589. --
  4590. -- Called by       : PerFile.Delete
  4591. --
  4592. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  4593. --
  4594. -- Amendments      :                        (  /  /  )
  4595. --
  4596. -- Notes           : 
  4597. --
  4598. -------------------------------------------------------------------------------
  4599.  
  4600.  
  4601. type DeleteParameters is
  4602.  
  4603.      record
  4604.  
  4605.        CountVariable : long_integer ;
  4606.        FileNumber : long_integer ;
  4607.        NumberOfConditions : long_integer ;
  4608.  
  4609.      end record ;
  4610.  
  4611.  
  4612. DeleteRequest : long_integer:=11;
  4613.  
  4614. Params : DeleteParameters ;
  4615.  
  4616. ParamsSize : long_integer ;
  4617.  
  4618. ParamsStart : long_integer ;
  4619.  
  4620. DummyReturn : long_integer ;
  4621.  
  4622.  
  4623. begin
  4624.  
  4625.   -- parameters INTO the record .
  4626.  
  4627.      -- notice that the size of the record is modified by the number of
  4628.      -- bytes of the record that contain information about the record to
  4629.      -- insert . ParamsSize is the size of trhe parameters to be transmitted 
  4630.      -- to RAPPORT .
  4631.  
  4632.  
  4633.   ParamsSize:=long_integer((DeleteParameters'Size/NumberOfBitsInAByte)) ;
  4634.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  4635.   Params.CountVariable:=CountVariable ;
  4636.   Params.NumberOfConditions:=NumberOfConditions ;
  4637.   Params.FileNumber:=FileNumber ;
  4638.  
  4639.   -- transmit to RAPPORT .
  4640.  
  4641.   DummyReturn:=syscall3(DeleteRequest,ParamsStart,ParamsSize,Channel) ;
  4642.  
  4643.   -- parameters OUT OF record .
  4644.  
  4645.   CountVariable:=Params.CountVariable ;
  4646.  
  4647.  
  4648. end ;
  4649.  
  4650.  
  4651.  
  4652.  
  4653.  
  4654.  
  4655. procedure R8STKY ( FileNumber : in long_integer ;
  4656.                    NumberOfFields : in long_integer ;
  4657.                    StartOfSortKeyArray : in long_integer ;
  4658.                    TypeOfRetrieval : in long_integer ;
  4659.                    Channel : in long_integer ) is
  4660.  
  4661.  
  4662.  
  4663. -------------------------------------------------------------------------------
  4664. --
  4665. -- Function        : User interface to R0STKY.To indicate to rapport the 
  4666. --             ordering that is desired  on a search. 
  4667. --
  4668. -- Input arguments : FileNumber:-The number of the file onto which to impose
  4669. --                 the ordering.
  4670. --             NumberOfFields -This is the number of fields in the sort
  4671. --                                   key array.From this the size in words of
  4672. --                                   the array can be calculated.
  4673. --             StartOfSortKeyArray:-The start address in ada space of the
  4674. --                       sort key array.
  4675. --             TypeOfRetrieval:- 0 => Normal
  4676. --                       1 => Order Unique
  4677. --                   Channel:-The number of the channel to the mailbox
  4678. --                  connecting to user call lib.
  4679. --
  4680. -- Output arguments: None .
  4681. --
  4682. -- Global variables: NumberOfBitsInAByte.
  4683. --
  4684. -- Calls to        : vms_call.syscall3
  4685. --
  4686. -- Called by       : PerFile.OrderingTreeWalker
  4687. --
  4688. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  4689. --
  4690. -- Amendments      :                        (  /  /  )
  4691. --
  4692. -- Notes           : 
  4693. --
  4694. -------------------------------------------------------------------------------
  4695.  
  4696.  
  4697. type StoreKeyParameters is
  4698.  
  4699.      record
  4700.  
  4701.        FileNumber : long_integer ;
  4702.        TypeOfRetrieval: long_integer ;
  4703.        NumberOfFields : long_integer ;
  4704.        SizeOfArray : long_integer ;
  4705.        StartOfSortKeyArray : long_integer ;
  4706.  
  4707.      end record ;
  4708.  
  4709.  
  4710. StoreKeyRequest : long_integer:=13;
  4711.  
  4712. Params : StoreKeyParameters ;
  4713.  
  4714. ParamsSize : long_integer ;
  4715.  
  4716. ParamsStart : long_integer ;
  4717.  
  4718. DummyReturn : long_integer ;
  4719.  
  4720. NumberOfBytesPerArrayElement : constant long_integer:=8 ;
  4721.  
  4722.  
  4723. begin
  4724.  
  4725.   -- parameters INTO record 
  4726.  
  4727.      -- note that the size of the record is modified by the number of bytes
  4728.      -- required to hold the description of the sort keys as size indicates
  4729.      -- the size of the parameters to be transmitted to RAPPORT .
  4730.  
  4731.  
  4732.   ParamsSize:=long_integer((StoreKeyParameters'Size/NumberOfBitsInAByte)
  4733.                             - NumberOfBytesOfRecordDescription) ;
  4734.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  4735.   Params.FileNumber:=FileNumber ;
  4736.   Params.TypeOfRetrieval:=TypeOfRetrieval ;
  4737.   Params.NumberOfFields:=NumberOfFields ;
  4738.   Params.SizeOfArray:=NumberOfFields*NumberOfBytesPerArrayElement ;
  4739.   Params.StartOfSortKeyArray:=StartOfSortKeyArray ;
  4740.  
  4741.   -- transmit to RAPPORT .
  4742.  
  4743.   DummyReturn:=syscall3(StoreKeyRequest,ParamsStart,ParamsSize,Channel) ;
  4744.  
  4745.   -- there is no return from RAPPORT .
  4746.  
  4747.  
  4748. end ;
  4749.  
  4750.  
  4751.  
  4752.  
  4753.  
  4754. procedure R8HOLD ( FileNumber : in long_integer ;
  4755.                    NumberOfConditions : in long_integer ;
  4756.                    NumberOfRecords : out long_integer ;
  4757.                    Channel : in long_integer ) is
  4758.  
  4759.  
  4760.  
  4761. -------------------------------------------------------------------------------
  4762. --
  4763. -- Function        : User interface to R0HOLD . Performs the ordered copy of
  4764. --                   the file .
  4765. --
  4766. -- Input arguments : FileNumber:-The number of the file to sort.
  4767. --                   NumberOfConditions:-The number of conditons on the file.
  4768. --                   Channel:-The number of the channel to the mailbox
  4769. --                            connecting to user call lib.      
  4770. --
  4771. -- Output arguments: NumberOfRecords:-The number of records in the sort.
  4772. --
  4773. -- Global variables: NumberOfBitsInAByte.
  4774. --
  4775. -- Calls to        : vms_call.syscall3
  4776. --
  4777. -- Called by       : PerFile.Set_Ordered
  4778. --             PerFile.Set_Unique
  4779. --
  4780. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  4781. --
  4782. -- Amendments      :                        (  /  /  )
  4783. --
  4784. -- Notes           : 
  4785. --
  4786. -------------------------------------------------------------------------------
  4787.  
  4788.  
  4789. type HoldParameters is
  4790.  
  4791.      record
  4792.  
  4793.        FileNumber : long_integer ;
  4794.        NumberOfConditions : long_integer ;
  4795.        NumberOfRecords : long_integer ;
  4796.  
  4797.      end record ;
  4798.  
  4799.  
  4800. HoldRequest : long_integer:=14;
  4801.  
  4802. Params : HoldParameters ;
  4803.  
  4804. ParamsSize : long_integer ;
  4805.  
  4806. ParamsStart : long_integer ;
  4807.  
  4808. DummyReturn : long_integer ;
  4809.  
  4810.  
  4811. begin
  4812.  
  4813.   -- parameters INTO record .
  4814.  
  4815.   ParamsSize:=long_integer(HoldParameters'Size/NumberOfBitsInAByte) ;
  4816.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  4817.   Params.FileNumber:=FileNumber ;
  4818.   Params.NumberOfConditions:=NumberOfConditions ;
  4819.  
  4820.   -- transmit to RAPPORT .
  4821.  
  4822.   DummyReturn:=syscall3(HoldRequest,ParamsStart,ParamsSize,Channel) ;
  4823.  
  4824.   -- parameters OUT OF record .
  4825.  
  4826.   NumberOfRecords:=Params.NumberOfRecords ;
  4827.  
  4828.  
  4829. end ;
  4830.  
  4831.  
  4832.  
  4833.  
  4834.  
  4835. procedure R8ENRV ( CountVariable : in long_integer ;
  4836.                    ErrorCode : out long_integer ;
  4837.                    Channel : in long_integer ) is
  4838.  
  4839.  
  4840.  
  4841. -------------------------------------------------------------------------------
  4842. --
  4843. -- Function        : User interface to R0ENRV.Used to end an ordered search.
  4844. --
  4845. -- Input arguments : CountVariable:-Pointer to the last record accessed.
  4846. --                   Channel:-Number of the channel to the mailbox connecting
  4847. --                            to user call lib.
  4848. --
  4849. -- Output arguments: ErrorCode:-An indication as to the success of R0ENRV.
  4850. --                    A value < -1 indicates a serious error.
  4851. --
  4852. -- Global variables: NumberOfBitsInAByte
  4853. --
  4854. -- Calls to        : vms_call.syscall3
  4855. --
  4856. -- Called by       : PerFile.Clear_Selector
  4857. --
  4858. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  4859. --
  4860. -- Amendments      :                        (  /  /  )
  4861. --
  4862. -- Notes           : 
  4863. --
  4864. -------------------------------------------------------------------------------
  4865.  
  4866.  
  4867. type EndRetrieveParameters is
  4868.     
  4869.      record
  4870.  
  4871.        ErrorCode : long_integer ;
  4872.        CountVariable : long_integer ;
  4873.  
  4874.      end record ;
  4875.  
  4876.  
  4877. EndRetrieveRequest : long_integer:=15;
  4878.  
  4879. Params : EndRetrieveParameters ;
  4880.  
  4881. ParamsSize : long_integer ;
  4882.  
  4883. ParamsStart : long_integer ;
  4884.  
  4885. DummyReturn : long_integer ;
  4886.  
  4887.  
  4888. begin
  4889.  
  4890.   -- parameters INTO record .
  4891.  
  4892.   ParamsSize:=long_integer(EndRetrieveParameters'Size/NumberOfBitsInAByte) ;
  4893.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  4894.   Params.CountVariable:=CountVariable ;
  4895.  
  4896.   -- transmit to RAPPORT .
  4897.  
  4898.   DummyReturn:=syscall3(EndRetrieveRequest,ParamsStart,ParamsSize,Channel) ;
  4899.  
  4900.   -- parameters OUT OF record .
  4901.  
  4902.   ErrorCode:=Params.ErrorCode ;
  4903.  
  4904. end ;
  4905.  
  4906.  
  4907.  
  4908.  
  4909.  
  4910.  
  4911.  
  4912. procedure R8RTRV ( FileNumber : in long_integer ;
  4913.                    CountVariable : in out long_integer ;
  4914.                    SizeOfRecord : in long_integer ;
  4915.                    StartOfRecord : in long_integer ;
  4916.                    Channel : in long_integer ) is
  4917.  
  4918.  
  4919.  
  4920. -------------------------------------------------------------------------------
  4921. --
  4922. -- Function        : User interface to R0RTRV.Fetches a record for an ordered 
  4923. --             search.
  4924. --
  4925. -- Input arguments : CountVariable:-Indicates the last record accessed.
  4926. --                   SizeOfRecord:-The size of the record that is to be got.
  4927. --             StartOfRecord:-The start address in ada space to put 
  4928. --                                  the got record.
  4929. --                   Channel:-The number of the channel to the mailbox
  4930. --                  connecting to user calll ib.
  4931. --
  4932. -- Output arguments: CountVariable:-Indicates the record that has just been
  4933. --                        retrieved.In the next call to R8RTRV in
  4934. --                    this particular set wilkl have this value
  4935. --                    as a pointer to the last record accessed.
  4936. --
  4937. -- Global variables: NumberOfBitsInAByte , NumberOfBytesOfRcordDescription .
  4938. --
  4939. -- Calls to        : vms_call.syscall3
  4940. --
  4941. -- Called by       : PerFile.Searc
  4942. --
  4943. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  4944. --
  4945. -- Amendments      :                        (  /  /  )
  4946. --
  4947. -- Notes           : 
  4948. --
  4949. -------------------------------------------------------------------------------
  4950.  
  4951.  
  4952. type RetrieveParameters is
  4953.  
  4954.      record
  4955.  
  4956.        CountVariable : long_integer ;
  4957.        FileNumber : long_integer ;
  4958.        SizeOfRecord : long_integer ;
  4959.        StartOfRecord : long_integer ;
  4960.      
  4961.      end record ;
  4962.  
  4963.  
  4964.  
  4965. RetrieveRequest : long_integer:=17;
  4966.  
  4967. Params : RetrieveParameters ;
  4968.  
  4969. ParamsSize : long_integer ;
  4970.  
  4971. ParamsStart : long_integer ;
  4972.  
  4973. DummyReturn : long_integer ;
  4974.  
  4975.  
  4976. begin
  4977.  
  4978.  
  4979.   -- parameters into record .
  4980.  
  4981.      -- note that the size is modified by the number of bytes needed to
  4982.      -- hold the description of the record . This is as the size is the
  4983.      -- size of the parameters to be transmitted to RAPPORT .
  4984.  
  4985.  
  4986.   ParamsSize:=long_integer((RetrieveParameters'Size/NumberOfBitsInAByte)
  4987.                             - NumberOfBytesOfRecordDescription) ;
  4988.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  4989.   Params.CountVariable:=CountVariable ;
  4990.   Params.FileNumber := FileNumber ;
  4991.   Params.StartOfRecord:=StartOfREcord ;
  4992.   Params.SizeOfREcord:=SizeOfREcord ;
  4993.  
  4994.   -- transmit to RAPPORT .
  4995.  
  4996.   DummyReturn:=syscall3(RetrieveRequest,ParamsStart,ParamsSize,Channel) ;
  4997.  
  4998.   -- parameters OUT OF record .
  4999.  
  5000.   CountVariable := Params.CountVariable ;
  5001.  
  5002. end ;
  5003.  
  5004.  
  5005.  
  5006.  
  5007.  
  5008. procedure R8CLFI ( FileNumber : in long_integer ;
  5009.                    ErrorCode : out long_integer ;
  5010.                    Channel : in long_integer ) is
  5011.  
  5012.  
  5013. -------------------------------------------------------------------------------
  5014. --
  5015. -- Function        : User interface to R0CLFI.To clear a specified file.
  5016. --
  5017. -- Input arguments : FileNumber:-Number of the file to clear.
  5018. --                   Channel:-The number of the channel to the mailbox
  5019. --                            connecting to user calll ib.
  5020. --
  5021. -- Output arguments: ErrorCode:-Indicator as to the success of the execution
  5022. --                    of R0CLFI.An Error code < -1 indicates that
  5023. --                a serious error has occvurred.
  5024. --
  5025. -- Global variables: NumberOfBitsInAByte.
  5026. --
  5027. -- Calls to        : vms_call.syscall3
  5028. --
  5029. -- Called by       : PerFile.Clear
  5030. --
  5031. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  5032. --
  5033. -- Amendments      :                        (  /  /  )
  5034. --
  5035. -- Notes           : 
  5036. --
  5037. -------------------------------------------------------------------------------
  5038.  
  5039.  
  5040. type ClearFileParameters is
  5041.  
  5042.      record
  5043.  
  5044.        ErrorCode : long_integer ;
  5045.        FileNumber : long_integer ;
  5046.  
  5047.      end record ;
  5048.  
  5049.  
  5050. ClearFileRequest : long_integer:=18;
  5051.  
  5052. Params : ClearFileParameters ;
  5053.  
  5054. ParamsSize : long_integer ;
  5055.  
  5056. ParamsStart : long_integer ;
  5057.  
  5058. DummyReturn : long_integer ;
  5059.  
  5060.  
  5061. begin
  5062.  
  5063.   -- parameters INTO record .
  5064.  
  5065.   ParamsSize:=long_integer(ClearFileParameters'Size/NumberOfBitsInAByte) ;
  5066.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  5067.   Params.FileNumber:=FileNumber ;
  5068.  
  5069.   -- transmit to RAPPORT .
  5070.  
  5071.   DummyReturn:=syscall3(ClearFileRequest,ParamsStart,ParamsSize,Channel) ;
  5072.  
  5073.   -- parameters OUT OF record .
  5074.  
  5075.   ErrorCode:=Params.ErrorCode ;
  5076.  
  5077. end ;
  5078.  
  5079.  
  5080.  
  5081.  
  5082.  
  5083.  
  5084.  
  5085. procedure R8LOCK ( FileNumber : in long_integer ;
  5086.                    ReadWriteSwitch : in long_integer ;
  5087.                    ErrorCode : out long_integer ;
  5088.                    Channel : in long_integer ) is
  5089.  
  5090.  
  5091.  
  5092. -------------------------------------------------------------------------------
  5093. --
  5094. -- Function        : User interface to R0LOCK.To lock a particular file.
  5095. --
  5096. -- Input arguments : FileNumber:-The number of the file to lock.
  5097. --                   ReadWriteSwitch:-An indicator as tio the type of lock
  5098. --                          required on the file.
  5099. --                   Channel:-The number of the channel to the mailbox
  5100. --                  connecting to user calll lib.
  5101. --
  5102. -- Output arguments: ErrorCode:-Indicatiopn as to the success of R0LOCK.An
  5103. --                    Error code < -1 indicates a serious error.
  5104. --
  5105. -- Global variables: NumberOfBitsInAByte.
  5106. --
  5107. -- Calls to        : vms_call.syscall3
  5108. --
  5109. -- Called by       : PerFile.Lock
  5110. --
  5111. -- Author          : M.D.DICK               (28/1/85)     Version 1.0
  5112. --
  5113. -- Amendments      :                        (  /  /  )
  5114. --
  5115. -- Notes           : 
  5116. --
  5117. -------------------------------------------------------------------------------
  5118.  
  5119.  
  5120.  
  5121. type LockParameters is
  5122.  
  5123.      record
  5124.  
  5125.        ErrorCode : long_integer ;
  5126.        FileNumber : long_integer ;
  5127.        ReadWriteSwitch : long_integer ;
  5128.  
  5129.      end record ;
  5130.  
  5131.  
  5132. LockRequest : long_integer:=19;
  5133.  
  5134. Params : LockParameters ;
  5135.  
  5136. ParamsSize : long_integer ;
  5137.  
  5138. ParamsStart : long_integer ;
  5139.  
  5140. DummyReturn : long_integer ;
  5141.  
  5142.  
  5143. begin
  5144.  
  5145.   -- parameters INTO the record .
  5146.  
  5147.   ParamsSize:=long_integer(LockParameters'Size/NumberOfBitsInAByte) ;
  5148.   ParamsStart:=AddressToLongInteger(Params'Address) ;
  5149.   Params.FileNumber:=FileNumber ;
  5150.   Params.ReadWriteSwitch:=ReadWriteSwitch ; 
  5151.  
  5152.   -- transmit to RAPPORT .
  5153.  
  5154.   DummyReturn:=syscall3(LockRequest,ParamsStart,ParamsSize,Channel) ;
  5155.  
  5156.   -- parameters OUT OF record .
  5157.  
  5158.   ErrorCode:=Params.ErrorCode ;
  5159.  
  5160.  
  5161. end ;
  5162.  
  5163.  
  5164.  
  5165.  
  5166.  
  5167.  
  5168.  
  5169. end R8LIB ;
  5170.  
  5171. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  5172. --PERDDF.TXT
  5173. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  5174. ----------------------------------------------------------------------------
  5175. --                                                                        --
  5176. -- This package is a set of procedures suitable for use on any file . It  --
  5177. -- contains these procedures and also the set of global data neccesary    --
  5178. -- for an activation of RAPPORT . A new package is required for every     --
  5179. -- DDF accessed as different CHECKSUMS and LAST_FILES will be in          --
  5180. -- operation .                                                            --
  5181. --                                                                        --
  5182. -- To instantiate for each seperate ddf :-                                --
  5183. --                                                                        --
  5184. --          Replace  %1 with the value of the CheckSum determined by      --
  5185. --                      RCP'ing a dummy fortran program .                 --
  5186. --          Replace  %2 with the value of the last file determoined as    --
  5187. --                      worst .                                           --
  5188. --          Replace  %3 with the name of the ddf                          --
  5189. --                                                                        --
  5190. --                                                                        --
  5191. --  Exit finally as %3.txt .                                              --
  5192. --                                                                        --
  5193. ----------------------------------------------------------------------------
  5194.  
  5195.  
  5196.  
  5197. WITH TEXT_IO , R8LIB ; USE TEXT_IO , R8LIB ;
  5198. with unchecked_conversion , system ;
  5199. package %3 is
  5200.  
  5201.  
  5202.    RAPPORT_ERROR : exception;
  5203.  
  5204.    type GENERAL_ELEMENT is (ANY_ELEMENT,ALL_ELEMENTS);
  5205.  
  5206.    type LOCKING_MODE is (READ, WRITE);
  5207.  
  5208.  
  5209. -- Non-generic rapport access procedures .
  5210.  
  5211.    procedure RAPPORT_STATUS(ERROR_NO : out LONG_INTEGER;
  5212.                             TASK_NO : out LONG_INTEGER;
  5213.                             TRANS_NO : out LONG_INTEGER);
  5214.  
  5215.    procedure STARTRAPPORT;
  5216.  
  5217.    procedure ENDRAPPORT;
  5218.  
  5219.    procedure TRANSACT;
  5220.  
  5221.    procedure COMMIT;
  5222.  
  5223.    procedure BACKOUT;
  5224.  
  5225.    procedure BAILOUT;
  5226.  
  5227.  
  5228.  
  5229.  
  5230.  
  5231.  
  5232. -- Generic data dependant on the ddf assosciated with this package .
  5233.  
  5234.    CHECKSUM : constant LONG_INTEGER := %1 ;
  5235.    LAST_FILE : constant LONG_INTEGER := %2  ;
  5236.  
  5237. -- Non-generic global data required by a rapport application .
  5238.  
  5239.    RAPPORT_STARTED : BOOLEAN;
  5240.    TASK_NUMBER : LONG_INTEGER;
  5241.    MAILBOX : LONG_INTEGER;
  5242.    TRANSACTION : LONG_INTEGER;
  5243.    ERROR_CODE : LONG_INTEGER;
  5244.  
  5245.    LOCKNUMBER : constant array (LOCKING_MODE) of LONG_INTEGER :=
  5246.          (1, 2);
  5247.  
  5248.  
  5249. -- Information must be kept as to the current and the currently active
  5250. -- search loops and their assosciated types . A search loop can be 
  5251. -- normal ordered or unique.There can be a maximum of 26 active search
  5252. -- loops.
  5253.  
  5254.    type SELECTION is (NORMAL , ORDERED , UNIQUE) ;
  5255.  
  5256.    MAX_STACK_SIZE : constant integer:=26 ;
  5257.  
  5258.    SELECTOR_STACK : array(1..MAX_STACK_SIZE) of SELECTION ;
  5259.  
  5260.    CURRENT_LEVEL : integer :=1 ;
  5261.  
  5262.  
  5263.  
  5264. -- The file dependant procedured require a function to convert between an
  5265. -- address and long_integer format .
  5266.  
  5267.    function AddressToLongInteger is new Unchecked_Conversion(System.address,
  5268.                                                              long_integer ) ;
  5269.  
  5270.  
  5271. end ;
  5272.  
  5273.  
  5274.  
  5275. package body %3 is
  5276.  
  5277.  
  5278.  
  5279.  
  5280.  
  5281.  
  5282.    procedure RAPPORT_STATUS(ERROR_NO : out LONG_INTEGER;
  5283.                             TASK_NO : out LONG_INTEGER;
  5284.                             TRANS_NO : out LONG_INTEGER) is
  5285.  
  5286. -------------------------------------------------------------------------------
  5287. --
  5288. -- Function        : To return the current status.Can be used on a RAPPORT
  5289. --                   exception to discover the error_code and the other
  5290. --                   status information
  5291. --
  5292. -- Input arguments : None .
  5293. --
  5294. -- Output arguments: Error_No : The current error number 0 => no error .
  5295. --                   Task_no  : The number assigned by the nucleus to this 
  5296. --                              task 
  5297. --                   Trans_No : If we are in a transaction set then this
  5298. --                              is the number assigned to the transaction 
  5299. --                              by the nucleus .
  5300. --
  5301. -- Global variables: ERROR_CODE , TASK_NUMBER , TRANSACTION_NUMBER
  5302. --
  5303. -- Calls to        : None.
  5304. --
  5305. -- Called by       : ADA Application programs .
  5306. --
  5307. -- Author          : RP                     (  /  /  )     Version 1.0
  5308. --
  5309. -- Amendments      :                        (  /  /  )
  5310. --
  5311. -- Notes           : 
  5312. --
  5313. -------------------------------------------------------------------------------
  5314.  
  5315.  
  5316.  
  5317.    begin
  5318.  
  5319.       ERROR_NO := ERROR_CODE;
  5320.       TASK_NO := TASK_NUMBER;
  5321.       TRANS_NO := TRANSACTION;
  5322.  
  5323.    end;
  5324.  
  5325.  
  5326.  
  5327.  
  5328.  
  5329.    procedure STARTRAPPORT is
  5330.  
  5331. -------------------------------------------------------------------------------
  5332. --
  5333. -- Function        : This procedure establishes a connection between an ADA
  5334. --                   application program and the RAPPORT nucleus.
  5335. --
  5336. -- Input arguments : None .
  5337. --
  5338. -- Output arguments: None .
  5339. --
  5340. -- Global variables: ERROR_CODE , TASK_NUMBER , CHECKSUM , LAST_FILE , MAILBOX
  5341. --                   RAPPORT_STARTED.
  5342. --
  5343. -- Calls to        : R8LIB.R8STAR .
  5344. --
  5345. -- Called by       : ADA Application program .
  5346. --
  5347. -- Author          : RP                      (  /  /  )     Version 1.0
  5348. --
  5349. -- Amendments      :                        (  /  /  )
  5350. --
  5351. -- Notes           : 
  5352. --
  5353. -------------------------------------------------------------------------------
  5354.  
  5355.  
  5356.  
  5357.    begin
  5358.  
  5359. --      put("%ADALIB-TRACEMSG-ENTERING STARTRAPPORT") ; new_line ;
  5360.  
  5361.       if RAPPORT_STARTED then
  5362.        
  5363.          ERROR_CODE := -103;
  5364.          raise RAPPORT_ERROR;
  5365.  
  5366.       else
  5367.  
  5368.          ERROR_CODE := 0;
  5369.          R8STAR(CHECKSUM, LAST_FILE, TASK_NUMBER, ERROR_CODE, MAILBOX);
  5370.  
  5371.          if ERROR_CODE < -1 then
  5372.             raise RAPPORT_ERROR;
  5373.          else
  5374.             RAPPORT_STARTED := TRUE;
  5375.          end if;
  5376.  
  5377.       end if;
  5378.  
  5379. --      put("%ADALIB-TRACEMSG-LEAVING STARTRAPPORT") ; new_line ;
  5380.  
  5381.    end;
  5382.  
  5383.  
  5384.  
  5385.  
  5386.  
  5387.    procedure ENDRAPPORT is
  5388.  
  5389. -------------------------------------------------------------------------------
  5390. --
  5391. -- Function        : To stop the current intercation with the RAPPORT nucleus
  5392. --
  5393. -- Input arguments : None.
  5394. --
  5395. -- Output arguments: None.
  5396. --
  5397. -- Global variables: ERROR_CODE , MAILBOX , RAPPORT_STARTED .
  5398. --
  5399. -- Calls to        : R8LIB.R8ENDR
  5400. --
  5401. -- Called by       : ADA Application program .
  5402. --
  5403. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  5404. --
  5405. -- Amendments      :                        (  /  /  )
  5406. --
  5407. -- Notes           : 
  5408. --
  5409. -------------------------------------------------------------------------------
  5410.  
  5411.  
  5412.  
  5413.    begin
  5414.  
  5415. --     put("%ADALIB-TRACEMSG-ENTERING ENDRAPPORT") ; NEW_LINE ;
  5416.   
  5417.      if RAPPORT_STARTED then
  5418.  
  5419.        ERROR_CODE:=0 ;
  5420.  
  5421.        R8ENDR ( ERROR_CODE , MAILBOX ) ;
  5422.    
  5423.        RAPPORT_STARTED := FALSE ;
  5424.  
  5425.        if ERROR_CODE < -1 then
  5426.           raise RAPPORT_ERROR ;
  5427.        end if ;
  5428.  
  5429.      else
  5430.  
  5431.        ERROR_CODE := -100 ;
  5432.        raise RAPPORT_ERROR ;
  5433.  
  5434.      end if ;
  5435.  
  5436.  
  5437. --     put("%ADALIB-TRACEMSG-LEAVING ENDRAPPORT") ; NEW_LINE ;
  5438.  
  5439.    end;
  5440.  
  5441.  
  5442.    procedure TRANSACT is
  5443.  
  5444.  
  5445. -------------------------------------------------------------------------------
  5446. --
  5447. -- Function        : To start a transaction set .
  5448. --
  5449. -- Input arguments : None .
  5450. --
  5451. -- Output arguments: None .
  5452. --
  5453. -- Global variables: ERROR_CODE , MAILBOX , TRANSACTION_NUMBER .
  5454. --
  5455. -- Calls to        : R8LIB.R8TRAN .
  5456. --
  5457. -- Called by       : ADA Application program .
  5458. --
  5459. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  5460. --
  5461. -- Amendments      :                        (  /  /  )
  5462. --
  5463. -- Notes           : 
  5464. --
  5465. -------------------------------------------------------------------------------
  5466.  
  5467.  
  5468.  
  5469.    begin
  5470.  
  5471. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE TRANSACT") ; NEW_LINE ;
  5472.  
  5473.      if RAPPORT_STARTED then 
  5474.  
  5475.        ERROR_CODE:=0 ;
  5476.  
  5477.        R8TRAN ( TRANSACTION , ERROR_CODE , MAILBOX ) ;
  5478.  
  5479.        if ERROR_CODE < -1 then
  5480.           raise RAPPORT_ERROR ;
  5481.        end if ;
  5482.  
  5483.      else 
  5484.  
  5485.        ERROR_CODE := -100 ;
  5486.        raise RAPPORT_ERROR ;
  5487.  
  5488.      end if ;
  5489.  
  5490.  
  5491.  
  5492. --     put("%ADALIB-TRACEMSG-LEAVING PROCEDURE TRANSACT") ; NEW_LINE ;
  5493.  
  5494.    end;
  5495.  
  5496.  
  5497.  
  5498.  
  5499.  
  5500.  
  5501.  
  5502.    procedure COMMIT is
  5503.  
  5504. -------------------------------------------------------------------------------
  5505. --
  5506. -- Function        : To commit the transaction set marked by the transact
  5507. --                   command to the database .
  5508. --
  5509. -- Input arguments : None.
  5510. --
  5511. -- Output arguments: None.
  5512. --
  5513. -- Global variables: ERROR_CODE , MAILBOX .
  5514. --
  5515. -- Calls to        : R8LIB.R8COMT .
  5516. --
  5517. -- Called by       : ADA Application program .
  5518. --
  5519. -- Author          : RP/MDD                  (  /  /  )     Version 1.0
  5520. --
  5521. -- Amendments      :                        (  /  /  )
  5522. --
  5523. -- Notes           : 
  5524. --
  5525. -------------------------------------------------------------------------------
  5526.  
  5527.  
  5528.  
  5529.    begin
  5530.  
  5531. --     put("%ADALIB-TRACEMSG-ENETERINT PROCEDURE TRACE") ; NEW_LINE ;
  5532.  
  5533.      if RAPPORT_STARTED then 
  5534.  
  5535.        ERROR_CODE:=0 ;
  5536.  
  5537.        R8COMT ( ERROR_CODE , MAILBOX ) ;
  5538.  
  5539.        if ERROR_CODE < -1 then
  5540.           raise RAPPORT_ERROR ;
  5541.        end if ;
  5542.  
  5543.      else
  5544.  
  5545.        ERROR_CODE := -100 ;
  5546.        raise RAPPORT_ERROR ;
  5547.  
  5548.      end if ;
  5549.  
  5550.  
  5551. --     put("%ADALIB-TRACEMSG-LEAVING PROCEDURE COMMIT") ; NEW_LINE ;
  5552.  
  5553.    end;
  5554.  
  5555.  
  5556.  
  5557.  
  5558.  
  5559.  
  5560.    procedure BACKOUT is
  5561.  
  5562. -------------------------------------------------------------------------------
  5563. --
  5564. -- Function        : To backout of a transaction set marked by the command
  5565. --                   TRANSACT . 
  5566. --
  5567. -- Input arguments : None.
  5568. --
  5569. -- Output arguments: None.
  5570. --
  5571. -- Global variables: ERROR_CODE , MAILBOX .
  5572. --
  5573. -- Calls to        : R8LIB.BKTK
  5574. --
  5575. -- Called by       : ADA Application program .
  5576. --
  5577. -- Author          : RP/MDD                  (  /  /  )     Version 1.0
  5578. --
  5579. -- Amendments      :                        (  /  /  )
  5580. --
  5581. -- Notes           : 
  5582. --
  5583. -------------------------------------------------------------------------------
  5584.  
  5585.  
  5586.  
  5587.    begin
  5588.  
  5589. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE BACKOUT") ; NEW_LINE ;
  5590.  
  5591.      if RAPPORT_STARTED then 
  5592.  
  5593.        ERROR_CODE:=0 ;
  5594.  
  5595.        R8BKTK ( ERROR_CODE , MAILBOX ) ;
  5596.  
  5597.        if ERROR_CODE < -1 then
  5598.           raise RAPPORT_ERROR ;
  5599.        end if ;
  5600.  
  5601.      else
  5602.  
  5603.        ERROR_CODE := -100 ;
  5604.        raise RAPPORT_ERROR ;
  5605.  
  5606.      end if ;
  5607.  
  5608.  
  5609. --     put("%ADALIB-TRACEMSG-LEAVING PROCEDURE BNACKOUT") ; NEW_LINE ;
  5610.  
  5611.    end;
  5612.  
  5613.  
  5614.  
  5615.  
  5616.    procedure BAILOUT is
  5617.  
  5618. -------------------------------------------------------------------------------
  5619. --
  5620. -- Function        : On receipt of a rapport_error , if rapport is started to
  5621. --                   perform an endrapport . If an error is discovered then no 
  5622. --                   statement is executed as a loop situation could develop .
  5623. --              
  5624. -- Input arguments : None.
  5625. --
  5626. -- Output arguments: None.
  5627. --
  5628. -- Global variables: None .
  5629. --
  5630. -- Calls to        : EndRapport .
  5631. --
  5632. -- Called by       : ADA Application program .
  5633. --
  5634. -- Author          : RP/MDD                  (  /  /  )     Version 1.0
  5635. --
  5636. -- Amendments      :                        (  /  /  )
  5637. --
  5638. -- Notes           : 
  5639. --
  5640. -------------------------------------------------------------------------------
  5641.  
  5642.  
  5643.    begin
  5644.  
  5645.       ENDRAPPORT;
  5646.  
  5647.    exception
  5648.       when RAPPORT_ERROR =>
  5649.          null;
  5650.    end;
  5651.  
  5652.  
  5653.  
  5654. begin
  5655.  
  5656. -- The following code is activated at the start of an application program
  5657. -- and sets the global variables to their intial values .
  5658.  
  5659.  
  5660.    RAPPORT_STARTED := FALSE;
  5661.    TASK_NUMBER := 0;
  5662.    MAILBOX := 0;
  5663.    TRANSACTION := 0;
  5664.    ERROR_CODE := 0;
  5665.  
  5666. end;
  5667. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  5668. --PERFILE.TXT
  5669. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  5670. ------------------------------------------------------------------------
  5671. ------------------------------------------------------------------------
  5672. --                                                                    --
  5673. --  This is a pseudo generic package suitable for hand instantiation  --
  5674. --  for the package for each database file.To instantiate :-          --
  5675. --                                                                    --
  5676. --          Replace  %1  with a complete set of type declarations     --
  5677. --                       for every field in the file including in     --
  5678. --                       the case of array fields a type definition   --
  5679. --                       for the base element of the array.           --
  5680. --                       note that field type renaming base type      --
  5681. --                       must be specified as subtypes :-             --
  5682. --                                                                    --
  5683. --                         subtype FIELD_TYPE is FLOAT ;              --
  5684. --                                                                    --
  5685. --          Replace  %2  with the components of the record            --
  5686. --                       description for the file.This will consist   --
  5687. --                       of a set of elements of the form :-          --
  5688. --                                                                    --
  5689. --                         FIELD_NAME : FIELD_TYPE ;                  --
  5690. --                                                                    --
  5691. --          Replace  %3  with the number of the file .                --
  5692. --                                                                    --
  5693. --          Replace  %4  with the name of the file .                  --
  5694. --                                                                    --
  5695. --          Replace %5   with the name of the ddf package .           --
  5696. --                                                                    --
  5697. --                                                                    --
  5698. --  Finally exit the edit by "EXIT %4.txt" .                          --
  5699. --                                                                    --
  5700. ------------------------------------------------------------------------
  5701. ------------------------------------------------------------------------
  5702.  
  5703.  
  5704.  
  5705.  
  5706. WITH TEXT_IO , R8LIB , %5 ; USE TEXT_IO , R8LIB , %5 ;
  5707. with unchecked_conversion , system ;
  5708. package %4 is
  5709.  
  5710.    procedure CLEAR ;
  5711.  
  5712.    procedure LOCK( LOCK : LOCKING_MODE );
  5713.  
  5714.  
  5715.    %1
  5716.    
  5717.  
  5718.    type DB_RECORD is
  5719.  
  5720.       record
  5721.  
  5722.         %2      
  5723.  
  5724.       end record ;
  5725.  
  5726.  
  5727.    type CONDITION_BLOCK;
  5728.    type CONDITION_TREE is access CONDITION_BLOCK;
  5729.  
  5730.  
  5731.    type TreeBlock is ( Conjunction , Condition ) ;
  5732.  
  5733.    type RHSParametersRecord is
  5734.  
  5735.         record
  5736.  
  5737.           ConditionNumber : long_integer ;
  5738.           FieldNumber : long_integer ;
  5739.           AnyAllSwitch : long_integer ;
  5740.           ArraySubscript : long_integer ;
  5741.           SizeOfRightHandSide : long_integer ;
  5742.           StartOfRightHandSide : long_integer ;
  5743.  
  5744.         end record ;
  5745.  
  5746.  
  5747.  
  5748.    type CONDITION_BLOCK is
  5749.  
  5750.       record
  5751.  
  5752.         BlockType : TreeBlock ;
  5753.         
  5754.         ConjunctionNumber : long_integer ;
  5755.         LeftPartOfConjunction : CONDITION_TREE ;
  5756.         RightPartOfConjunction : CONDITION_TREE ;
  5757.  
  5758.         RHSParameters : RHSParametersRecord ;
  5759.  
  5760.      end record ;
  5761.  
  5762.  
  5763.  
  5764.  
  5765.    type SELECTOR is
  5766.  
  5767.       record
  5768.  
  5769.         CountVariable : long_integer ;
  5770.         RetrievalStrategy : long_integer ;
  5771.         Level : integer ;
  5772.         Conditions : CONDITION_TREE ;
  5773.  
  5774.       end record;
  5775.  
  5776.   
  5777.    type ORDER_BLOCK;
  5778.    type ORDERING_TREE is access ORDER_BLOCK;
  5779.  
  5780.    type ORDER_BLOCK_TYPE is ( NODE , LEAF ) ;
  5781.  
  5782.    type ORDER_BLOCK is
  5783.  
  5784.       record
  5785.  
  5786.         BlockType : ORDER_BLOCK_TYPE ;
  5787.  
  5788.         LeftPart : ORDERING_TREE ;
  5789.         RightPart : ORDERING_TREE ;
  5790.  
  5791.         OrderingInformation : long_integer ;
  5792.  
  5793.       end record;
  5794.  
  5795.  
  5796.  MAX_NUMBER_OF_ORDER_FIELDS : constant integer := 10 ;
  5797.  
  5798.  type ORDERING_ARRAY is array(1..MAX_NUMBER_OF_ORDER_FIELDS) of long_integer ;
  5799.  
  5800.  
  5801.  
  5802.  
  5803.  
  5804.  
  5805.    procedure INSERT(REC : DB_RECORD);
  5806.  
  5807.    procedure UPDATE(REC : DB_RECORD);
  5808.  
  5809.    procedure STORE(REC : DB_RECORD);
  5810.  
  5811.  
  5812.  
  5813.    procedure FETCH(REC : out DB_RECORD;
  5814.                    EXISTS : out BOOLEAN;
  5815.                    CONDITIONS : CONDITION_TREE);
  5816.  
  5817.  
  5818.  
  5819.    procedure DELETE(NUMBER : out integer ;
  5820.                     CONDITIONS : CONDITION_TREE);
  5821.  
  5822.  
  5823.  
  5824.    procedure SET_SELECTOR(SELECTION : out SELECTOR);
  5825.  
  5826.    procedure SET_SELECTOR(SELECTION : out SELECTOR;
  5827.                           CONDITIONS : CONDITION_TREE);
  5828.  
  5829.    procedure SET_ORDERED(SELECTION : out SELECTOR;
  5830.                          ORDERING : ORDERING_TREE);
  5831.  
  5832.    procedure SET_ORDERED(SELECTION : out SELECTOR;
  5833.                          ORDERING : ORDERING_TREE;
  5834.                          CONDITIONS : CONDITION_TREE);
  5835.  
  5836.    procedure SET_UNIQUE(SELECTION : out SELECTOR;
  5837.                         ORDERING : ORDERING_TREE);
  5838.  
  5839.    procedure SET_UNIQUE(SELECTION : out SELECTOR;
  5840.                         ORDERING : ORDERING_TREE;
  5841.                         CONDITIONS : CONDITION_TREE);
  5842.  
  5843.  
  5844.  
  5845.    procedure SEARCH(SELECTION : in out SELECTOR;
  5846.                     REC : out DB_RECORD;
  5847.                     END_OF_SEARCH : out BOOLEAN);
  5848.  
  5849.  
  5850.  
  5851.    procedure CLEAR_SELECTOR(SELECTION : in out SELECTOR);
  5852.  
  5853.  
  5854.  
  5855.  
  5856.    function "and" ( LeftPart , RightPart : CONDITION_TREE ) 
  5857.      
  5858.             return CONDITION_TREE ;
  5859.  
  5860.  
  5861.    function "or" ( LeftPart , RightPart : CONDITION_TREE ) 
  5862.      
  5863.             return CONDITION_TREE ;
  5864.  
  5865.  
  5866.  
  5867.  
  5868.    function "&" ( LeftPart , RightPart : ORDERING_TREE )
  5869.  
  5870.             return ORDERING_TREE ;
  5871.  
  5872.  
  5873.  
  5874.  
  5875.  
  5876.  
  5877.   
  5878. end;
  5879.  
  5880.  
  5881.  
  5882.  
  5883.  
  5884.  
  5885.  
  5886. package body %4 is
  5887.  
  5888.  
  5889. FileNumber  : constant long_integer := %3 ;
  5890.  
  5891. NumberOfBitsInAByte : constant integer :=8 ;
  5892.  
  5893.  
  5894.  
  5895.  
  5896.  
  5897.  
  5898.  
  5899.  procedure OrderingTreeWalker ( OrderTree : in ORDERING_TREE ;
  5900.                                 OrderList : out ORDERING_ARRAY ;
  5901.                                 NumberOfFields : out integer ) is
  5902.  
  5903. -------------------------------------------------------------------------------
  5904. --
  5905. -- Function        : This procedure traverses the ordering tree of the form
  5906. --
  5907. --                                     node
  5908. --                                     /  \
  5909. --                                   info node
  5910. --                                        /  \
  5911. --
  5912. --                   produced by the functions "&" and up & down and produces
  5913. --                   as a result an array of ordering information .
  5914. --
  5915. --
  5916. -- Input arguments : OrderTree : A pointer to an order tree of the form 
  5917. --                               shown above .
  5918. --        
  5919. --
  5920. -- Output arguments: OrderList : An array representation of the order tree.
  5921. --                   NumberInList : The number of fields in the order.
  5922. --
  5923. -- Global variables: None.
  5924. --
  5925. -- Calls to        : WalkTree a nested sub-procedure.
  5926. --
  5927. -- Called by       : set_ordered .
  5928. --
  5929. -- Author          : MDD                     (  /  /  )     Version 1.0
  5930. --
  5931. -- Amendments      :                        (  /  /  )
  5932. --
  5933. -- Notes           : 
  5934. --
  5935. -------------------------------------------------------------------------------
  5936.  
  5937.  
  5938.  
  5939.     -- This is an inner procedure to the ordering tree walker . It
  5940.     -- recursively walks the ordering tree by :-
  5941.     -- LeftTree , Leaf , RightTree .
  5942.  
  5943.      procedure WalkTree ( Tree : in ORDERING_TREE  ;
  5944.                           CurrentNumber : in out integer ) is
  5945.  
  5946.         begin
  5947.     
  5948. --          put("%ADALIB-TRACEMSG-ENTERING PROCEDURE WALK TREE" ) ; NEW_LINE ;
  5949.  
  5950.           if Tree.BlockType = LEAF
  5951.  
  5952.              then CurrentNumber := CurrentNumber+1 ;
  5953.                   OrderList(CurrentNumber) := Tree.OrderingInformation ;
  5954.  
  5955.              else WalkTree ( Tree.LeftPart , CurrentNumber  ) ;
  5956.                   WalkTree ( Tree.RightPart , CurrentNumber  ) ;
  5957.  
  5958.           end if ;
  5959.  
  5960. --          put("%ADALIB-TRACEMSG-LEAVING PROCEDURE WALK TREE") ; NEW_LINE ;
  5961.  
  5962.          end WalkTree ;
  5963.  
  5964.  
  5965.  
  5966.  
  5967.  
  5968.  
  5969.    begin
  5970.  
  5971. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE ORDERING TREE WALKER") ;
  5972.      NEW_LINE ;
  5973.  
  5974.  
  5975.      NumberOfFields := 0 ;
  5976.  
  5977.      if OrderTree /= null
  5978.         then WalkTree ( OrderTree  , NumberOfFields);
  5979.      end if ;
  5980.  
  5981. --     put("%ADALIB-TTRACEMSG-LEAVING PROCEDURE ORDERING TREE WALKER") ;   
  5982.      NEW_LINE ;
  5983.  
  5984.    end OrderingTreeWalker ;
  5985.  
  5986.  
  5987.  
  5988.  
  5989.  
  5990.  
  5991.   procedure ConditionTreeWalker ( ConditionTree : in CONDITION_TREE ;
  5992.                                   NumberOfConditions : out long_integer ) is
  5993.  
  5994. -------------------------------------------------------------------------------
  5995. --
  5996. -- Function        : This procedure walks over an inputed Condition tree 
  5997. --                   producing a number of calls to r8cond one for each
  5998. --                   condition.
  5999. --                   The actual mechanics of the traversal are very difficult
  6000. --                   to explain . It is best to work through an example.
  6001. --
  6002. -- Input arguments : ConditionTree : A pointer to a condition tree.
  6003. --
  6004. -- Output arguments: NumberOfConditions : The number of conditions found.
  6005. --
  6006. -- Global variables: RAPPORT.MAILBOX , FileNumber .
  6007. --
  6008. -- Calls to        : R8LIB.R8COND , UnfoldConditionTree a nested sub-procedure 
  6009. --
  6010. -- Called by       : set_ordered , search
  6011. --
  6012. -- Author          : MDD                      (  /  /  )     Version 1.0
  6013. --
  6014. -- Amendments      :                        (  /  /  )
  6015. --
  6016. -- Notes           : 
  6017. --
  6018. -------------------------------------------------------------------------------
  6019.  
  6020.  
  6021.  
  6022.   ReturnedParametersOut : RHSParametersRecord ;
  6023.   LevelInTheConditionTree : long_integer :=0 ;
  6024.   NumberOfCurrentConditionInSet : long_integer := 0 ;
  6025.   NoConjunction : long_integer := 0 ;
  6026.  
  6027.  
  6028.  
  6029.  
  6030.     procedure UnfoldConditionTree ( ConditionTreePointer : 
  6031.                                         in CONDITION_TREE ;
  6032.                               LevelInTheTree : in long_integer ;
  6033.                               FoundParameters : out RHSParametersRecord ) is
  6034.  
  6035. -------------------------------------------------------------------------------
  6036. --
  6037. -- Function        : To recursively walk the condition tree.
  6038. --
  6039. -- Input arguments : ConditoionTreePointer : a pointer to a condition tree.
  6040. --                   Level : the current level reached in the condition tree
  6041. --
  6042. -- Output arguments: FoundParameters : the parameter set located at the bottom
  6043. --                                     of the tree.
  6044. --
  6045. -- Global variables: RAPPORT.MAILBOX , FileNumber .
  6046. --
  6047. -- Calls to        : Itself .
  6048. --
  6049. -- Called by       : Itself , ConditionTreeWalker .
  6050. --
  6051. -- Author          : MDD                      (  /  /  )     Version 1.0
  6052. --
  6053. -- Amendments      :                        (  /  /  )
  6054. --
  6055. -- Notes           : 
  6056. --
  6057. -------------------------------------------------------------------------------
  6058.          
  6059.  
  6060.     NewLevelInTheConditionTree : long_integer  ;
  6061.     ThisConjunction : long_integer ;
  6062.     ReturnedParameters : RHSParametersRecord ;
  6063.  
  6064.     begin
  6065.  
  6066. --      put("%ADALIB-TRACEMSG-ENTERING UNFOOLD PART OF WALKER") ; NEW_LINE ;
  6067.  
  6068.       if ConditionTreePointer.BlockType = Condition
  6069.  
  6070.          -- We have recursed to the bottom of the tree and so the found
  6071.          -- parameters are returned.
  6072.  
  6073.          then FoundParameters := ConditionTreePointer.RHSParameters ;
  6074.  
  6075.          -- Else the bottom has not been reached
  6076.  
  6077.          else
  6078.              -- We are going down one more level so adjust the level.
  6079.  
  6080.              NewLevelInTheConditionTree := LevelInTheTree + 10 ;
  6081.  
  6082.  
  6083.              -- Recurse down the left hand side of the tree .
  6084.  
  6085.              UnfoldConditionTree ( ConditionTreePointer.LeftPartOfConjunction ,
  6086.                                   NewLevelInTheConditionTree ,
  6087.                                   ReturnedParameters ) ;
  6088.  
  6089.                                   
  6090.              -- We have returned with a set of parameters located at the 
  6091.              -- bottom of the tree so we must do an r8cond on them .
  6092.  
  6093.  
  6094.              -- Adjust the conjunction number to reflect the level in the tree
  6095.           
  6096.              ThisConjunction := ConditionTreePointer.ConjunctionNumber +
  6097.                               LevelInTheTree ;                              
  6098.  
  6099.              NumberOfCurrentConditionInSet :=
  6100.                    NumberOfCurrentConditionInset + 1 ;
  6101.  
  6102.              R8COND ( FileNumber , NumberOfCurrentConditionInSet ,
  6103.                       ReturnedParameters.FieldNumber ,
  6104.                       ReturnedParameters.AnyAllSwitch ,
  6105.                       ReturnedParameters.ArraySubscript ,
  6106.                       ReturnedParameters.ConditionNumber ,
  6107.                       ThisConjunction ,
  6108.                       ReturnedParameters.SizeOfRightHandSide ,
  6109.                       ReturnedParameters.StartOfRightHandSide ,
  6110.                       MAILBOX ) ;
  6111.  
  6112.  
  6113.  
  6114.              -- Recurse on down  the right hand side of the tree.
  6115.  
  6116.              UnfoldConditionTree ( ConditionTreePointer.RightPartOfConjunction ,
  6117.                                   NewLevelInTheConditionTree ,
  6118.                                   FoundParameters ) ;
  6119.  
  6120.  
  6121.        end if ;
  6122.  
  6123. --    put("%ADALIB-TRACEMSG-LEAVING UNFOLD PART OF TREE WALKER") ; NEW_LINE ;
  6124.  
  6125.     end UnfoldConditionTree ;
  6126.  
  6127.  
  6128.  
  6129.   begin
  6130.  
  6131.     
  6132. --    PUT("%ADALIB-TRACEMSG-ENETRING PROCEUDRE TREE WALKER") ; NEW_LINE ;
  6133.  
  6134.     if ConditionTree /= null
  6135.  
  6136.       
  6137.        then UnfoldConditionTree ( ConditionTree ,
  6138.                                  LevelInTheConditionTree ,
  6139.                                  ReturnedParametersOut ) ;
  6140.        
  6141.             NumberOfCurrentConditionInSet := 
  6142.                   NumberOfCurrentConditionInset + 1 ;
  6143.  
  6144.  
  6145.  
  6146.            -- The found parameters have no condition on their right side
  6147.            -- as they represent the last condition so the conjunction is 0 .
  6148.  
  6149.            R8COND ( FileNumber , NumberOfCurrentConditionInSet ,
  6150.                     ReturnedParametersOut.FieldNumber ,
  6151.                     ReturnedParametersOut.AnyAllSwitch ,
  6152.                     ReturnedParametersOut.ArraySubscript ,
  6153.                     ReturnedParametersOut.ConditionNumber ,
  6154.                     NoConjunction ,
  6155.                     ReturnedParametersOut.SizeOfRightHandSide ,
  6156.                     ReturnedParametersOut.StartOfRightHandSide ,
  6157.                     MAILBOX ) ;
  6158.   
  6159.  
  6160.  
  6161.             NumberOfConditions := NumberOfCurrentConditionInSet ;
  6162.        
  6163.       else  NumberOfConditions := 0 ;
  6164.  
  6165.  end if ;
  6166.  
  6167. --    put("%ADALIB-TRACEMSG-LEAVING PROCEDURE TREE WALKER") ; NEW_LINE ;
  6168.  
  6169.  end ConditionTreeWalker ;
  6170.  
  6171.  
  6172.  
  6173.  
  6174.  
  6175.  
  6176.    procedure CLEAR is
  6177.  
  6178.  
  6179. -------------------------------------------------------------------------------
  6180. --
  6181. -- Function        : This procedure clears the file that the package has been
  6182. --                   instantiated for .
  6183. --
  6184. -- Input arguments : None .
  6185. --
  6186. -- Output arguments: None .
  6187. --
  6188. -- Global variables: FileNumber , RAPPORT.MAILBOX , RAPPORT.ERROR_CODE .
  6189. --
  6190. -- Calls to        : R8LIB.R8CLFI
  6191. --
  6192. -- Called by       : ADA Application program .
  6193. --
  6194. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  6195. --
  6196. -- Amendments      :                        (  /  /  )
  6197. --
  6198. -- Notes           : 
  6199. --
  6200. -------------------------------------------------------------------------------
  6201.  
  6202.  
  6203.  
  6204.    begin
  6205.  
  6206. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE CLEAR") ; NEW_LINE ;
  6207.  
  6208.      if RAPPORT_STARTED then
  6209.  
  6210.        ERROR_CODE:=0 ;
  6211.   
  6212.        R8CLFI ( FileNumber , ERROR_CODE , MAILBOX ) ;
  6213.  
  6214.        if ERROR_CODE < -1 then
  6215.           raise RAPPORT_ERROR ;
  6216.        end if ;
  6217.  
  6218.      else
  6219.  
  6220.        ERROR_CODE := -100 ;
  6221.        raise RAPPORT_ERROR ;
  6222.  
  6223.  
  6224.      end if ;
  6225.  
  6226. --     put("%ADALIB-TRACEMSG-LEAVING PROCEDURE CLEARFILE") ; NEW_LINE ;
  6227.  
  6228.    end CLEAR  ;
  6229.  
  6230.  
  6231.   
  6232.  
  6233.  
  6234.    procedure LOCK(LOCK : LOCKING_MODE) is
  6235.  
  6236.  
  6237. -------------------------------------------------------------------------------
  6238. --
  6239. -- Function        : This procedure locks the file for either read or write 
  6240. --                   access for the user.
  6241. --
  6242. -- Input arguments : LOCK : An indication of the lock to be applied(read or
  6243. --                          write)
  6244. --
  6245. -- Output arguments: None.
  6246. --
  6247. -- Global variables: RAPPORT.ERROR_CODE , RAPPORT.MAILBOX , FileNumber , 
  6248. --                   LOCKNUMBER .
  6249. --
  6250. -- Calls to        : R8LIB.R8LOCK
  6251. --
  6252. -- Called by       : ADA Application program .
  6253. --
  6254. -- Author          : RP/MDD                  (  /  /  )     Version 1.0
  6255. --
  6256. -- Amendments      :                        (  /  /  )
  6257. --
  6258. -- Notes           : 
  6259. --
  6260. -------------------------------------------------------------------------------
  6261.  
  6262.  
  6263.  
  6264.    ReadWriteSwitch : long_integer ;
  6265.  
  6266.    begin
  6267.  
  6268. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE LOCK") ; NEW_LINE ;
  6269.  
  6270.      if RAPPORT_STARTED then
  6271.  
  6272.        ReadWriteSwitch := LOCKNUMBER ( LOCK ) ;
  6273.  
  6274.        ERROR_CODE := 0 ;
  6275.  
  6276.        R8LOCK ( FileNumber , ReadWriteSwitch , ERROR_CODE , MAILBOX ) ;
  6277.  
  6278.        if ERROR_CODE < -1 then
  6279.           raise RAPPORT_ERROR ;
  6280.        end if ;
  6281.  
  6282.      else
  6283.  
  6284.        ERROR_CODE := -100 ;
  6285.        raise RAPPORT_ERROR ;
  6286.  
  6287.      end if ;
  6288.  
  6289.  
  6290. --     put("%ADALIB-TRACEMSG-LEAVING PROCEDURE LOCK") ; NEW_LINE ;
  6291.  
  6292.  
  6293.    end LOCK ;
  6294.  
  6295.  
  6296.  
  6297.  
  6298.  
  6299.    procedure INSERT(REC : DB_RECORD) is
  6300.  
  6301. -------------------------------------------------------------------------------
  6302. --
  6303. -- Function        : This procedure inserts a record into the file.An error
  6304. --                   is returned if a record with the same prime key is
  6305. --                   already present.
  6306. --
  6307. -- Input arguments : REC : The record to insert .
  6308. --
  6309. -- Output arguments: None .
  6310. --
  6311. -- Global variables: FileNumber , RAPPORT.MAILBOX , RAPPORT.ERROR_CODE .
  6312. --
  6313. -- Calls to        : R8LIB.R8INRT , RAPPORT.AddressToLongInteger .
  6314. --
  6315. -- Called by       : ADA Application program
  6316. --
  6317. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  6318. --
  6319. -- Amendments      :                        (  /  /  )
  6320. --
  6321. -- Notes           : 
  6322. --
  6323. -------------------------------------------------------------------------------
  6324.  
  6325.  
  6326.  
  6327.    SizeOfRecord : long_integer ;
  6328.    StartOfRecord : long_integer ;
  6329.  
  6330.  
  6331.    begin
  6332.  
  6333. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE INSERT") ; NEW_LINE ;
  6334.  
  6335.      if RAPPORT_STARTED then
  6336.  
  6337.        -- Note that 'size returns bits and we require bytes
  6338.  
  6339.        SizeOfRecord := long_integer( DB_RECORD'size/NumberOfBitsInAByte) ;
  6340.        StartOfRecord := AddressToLongInteger ( REC'Address ) ;
  6341.  
  6342.        ERROR_CODE := 0 ;
  6343.  
  6344.        R8INRT ( FileNumber , SizeOfRecord , StartOfRecord , ERROR_CODE ,
  6345.                 MAILBOX ) ;
  6346.  
  6347.  
  6348.        -- A return of -7 indicates that the file is 90% full
  6349.  
  6350.        if ERROR_CODE = -7
  6351.           then put("  <<RAPPORT WARNING>>") ; new_line ; new_line ;
  6352.                put("    < File number ") ;
  6353.                system.put(integer(FileNumber)) ;
  6354.                put(" is greater than 90% full>") ;
  6355.                new_line ; new_line ;
  6356.        end if ;
  6357.  
  6358.  
  6359.  
  6360.        if ( ERROR_CODE < -1 ) and ( ERROR_CODE /= -7 )then
  6361.           raise RAPPORT_ERROR ;
  6362.        end if ;
  6363.  
  6364.  
  6365.      else
  6366.    
  6367.        ERROR_CODE := -100 ;
  6368.        raise RAPPORT_ERROR ;
  6369.  
  6370.      end if ;
  6371.  
  6372. --     put("%ADALIB-TRACEMSG-LEAVING PROCEDURE INSERT") ; NEW_LINE ;
  6373.  
  6374.  
  6375.    end INSERT;
  6376.  
  6377.  
  6378.  
  6379.  
  6380.  
  6381.  
  6382.    procedure UPDATE(REC : DB_RECORD) is
  6383.  
  6384. -------------------------------------------------------------------------------
  6385. --
  6386. -- Function        : To update the record in the file.
  6387. --
  6388. -- Input arguments : REC : The record to update .
  6389. --
  6390. -- Output arguments: None .
  6391. --
  6392. -- Global variables: FileNumber , RAPPORT.ERROR_CODE , RAPPORT.MAILBOX .
  6393. --
  6394. -- Calls to        : R8LIB.R8UPDT , RAPPORT.AddressToLongInteger .
  6395. --
  6396. -- Called by       : ADA Application program
  6397. --
  6398. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  6399. --
  6400. -- Amendments      :                        (  /  /  )
  6401. --
  6402. -- Notes           : 
  6403. --
  6404. -------------------------------------------------------------------------------
  6405.  
  6406.  
  6407.  
  6408.  
  6409.    SizeOfRecord : long_integer ;
  6410.  
  6411.    StartOfRecord : long_integer ;
  6412.  
  6413.  
  6414.    begin
  6415.    
  6416. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE UPDATE") ; NEW_LINE ;
  6417.  
  6418.      if RAPPORT_STARTED then
  6419.  
  6420.        -- Note that 'size returns bits and we require bytes.
  6421.  
  6422.        SizeOfRecord := long_integer ( DB_RECORD'size/NumberOfBitsInAByte )  ;
  6423.        StartOfRecord := AddressToLongInteger ( REC'address ) ;
  6424.  
  6425.        ERROR_CODE := 0 ;
  6426.  
  6427.        R8UPDT ( FileNumber , SizeOfRecord , StartOfRecord ,
  6428.                 ERROR_CODE , MAILBOX ) ;
  6429.  
  6430.        if ERROR_CODE < -1 then
  6431.           raise RAPPORT_ERROR ;
  6432.        end if ;
  6433.     
  6434.  
  6435.      else
  6436.  
  6437.        ERROR_CODE := -100 ;
  6438.        raise RAPPORT_ERROR ;
  6439.  
  6440.      end if ;
  6441.  
  6442.  
  6443. --     put("%ADALIB-TRACEMSG-LEAVING PROCEDURE UPDATE") ; NEW_LINE ;
  6444.  
  6445.  
  6446.  
  6447.    end UPDATE ;
  6448.  
  6449.  
  6450.  
  6451.  
  6452.  
  6453.  
  6454.    procedure STORE(REC : DB_RECORD) is
  6455.  
  6456.  
  6457. -------------------------------------------------------------------------------
  6458. --
  6459. -- Function        : To store the record in the database.If the record is 
  6460. --                   already present as determined by the prime key then  the
  6461. --                   record is updated.
  6462. --
  6463. -- Input arguments : REC : The record to update .
  6464. --
  6465. -- Output arguments: None.
  6466. --
  6467. -- Global variables: RAPPORT.MAILBOX , RAPPORT.ERROR_CODE , FileNumber
  6468. --
  6469. -- Calls to        : R8LIB.R8UPDT , RAPPORT.AddressToLongInteger .
  6470. --
  6471. -- Called by       : ADA Application program .
  6472. --
  6473. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  6474. --
  6475. -- Amendments      :                        (  /  /  )
  6476. --
  6477. -- Notes           : 
  6478. --
  6479. -------------------------------------------------------------------------------
  6480.  
  6481.  
  6482.  
  6483.    SizeOfRecord : long_integer ;
  6484.  
  6485.    StartOfRecord : long_integer ;
  6486.  
  6487.  
  6488.    begin
  6489.  
  6490. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE STORE") ; NEW_LINE ;
  6491.  
  6492.      if RAPPORT_STARTED then
  6493.  
  6494.        -- Note that 'size return s bits and we require bytes.
  6495.  
  6496.        SizeOfRecord := long_integer ( DB_RECORD'size/NumberOfBitsInAByte ) ;
  6497.        StartOfRecord := AddressToLongInteger ( REC'address ) ;
  6498.  
  6499.        ERROR_CODE := 0 ;
  6500.  
  6501.        R8STOR ( FileNumber , SizeOfRecord , StartOfRecord ,
  6502.                 ERROR_CODE , MAILBOX ) ;
  6503.  
  6504.  
  6505.       -- Error return of -7 => that the file is 90% full
  6506.  
  6507.        if ERROR_CODE = -7
  6508.           then put("  <<RAPPORT WARNING>>") ; new_line ; new_line ;
  6509.                put("    < File number ") ;
  6510.                system.put(integer(FileNumber)) ;
  6511.                put(" is greater than 90% full>") ;
  6512.                new_line ; new_line ;
  6513.        end if ;
  6514.  
  6515.  
  6516.  
  6517.        if ( ERROR_CODE < -1 ) and ( ERROR_CODE /= -7 )then
  6518.           raise RAPPORT_ERROR ;
  6519.        end if ;
  6520.  
  6521.  
  6522.      else
  6523.  
  6524.        ERROR_CODE := -100 ;
  6525.        raise RAPPORT_ERROR ;
  6526.  
  6527.      end if ;
  6528.  
  6529.  
  6530. --     put("%ADALIB-TRACEMSG-LEAVING PROCEDURE STORE") ; NEW_LINE ;
  6531.  
  6532.  
  6533.  
  6534.    end STORE ;
  6535.  
  6536.  
  6537.  
  6538.  
  6539.  
  6540.  
  6541.    procedure FETCH(REC : out DB_RECORD;
  6542.                    EXISTS : out BOOLEAN;
  6543.                    CONDITIONS : CONDITION_TREE) is
  6544.  
  6545.  
  6546. -------------------------------------------------------------------------------
  6547. --
  6548. -- Function        : This procedure returns a record from the file that 
  6549. --                   satisfies the input conditions.If more than one record
  6550. --                   satisfies the conditions then the return is
  6551. --                   non-deterministic.
  6552. --
  6553. -- Input arguments : CONDITIONS : A pointer to a condition tree detailing the
  6554. --                   set of conditions on the fetch. 
  6555. --
  6556. -- Output arguments: REC : The discovered database record if it is found .
  6557. --                   EXISTS : A boolean indicator saying if a record was found
  6558. --
  6559. -- Global variables: RAPPORT.MAILBOX , FileNumber , 
  6560. --
  6561. -- Calls to        : ConditionTreeWalker , R8LIB.R8FECH
  6562. --                   RAPPORT.AddressToLongInteger .
  6563. --
  6564. -- Called by       : ADA Application program .
  6565. --
  6566. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  6567. --
  6568. -- Amendments      :                        (  /  /  )
  6569. --
  6570. -- Notes           : 
  6571. --
  6572. -------------------------------------------------------------------------------
  6573.  
  6574.  
  6575.    -- CountVariable is an indication of the last record fetched.In this case as
  6576.    -- none has been fetched it is 0.
  6577.  
  6578.    CountVariable : long_integer := 0 ;
  6579.  
  6580.    
  6581.    -- RetrievalStrategy is an indication of how to fetch the record.
  6582.  
  6583.    RetrievalStrategy : long_integer := 0 ;
  6584.  
  6585.    NumberOfConditions : long_integer ;
  6586.  
  6587.  
  6588.    -- Level no longer serves a purpose.
  6589.  
  6590.    Level : long_integer := 0 ;
  6591.  
  6592.    SizeOfRecord : long_integer ;
  6593.  
  6594.    StartOfRecord : long_integer ;
  6595.  
  6596.  
  6597.  
  6598.  
  6599.    begin
  6600.  
  6601. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE FETCH") ; NEW_LINE ;
  6602.  
  6603.      if RAPPORT_STARTED then 
  6604.  
  6605.        SizeOfRecord := long_integer ( DB_RECORD'size/NumberOfBitsInAByte ) ;
  6606.        StartOfRecord := AddressToLongInteger ( REC'address ) ;
  6607.  
  6608.  
  6609.        -- The set of conditions are sent to the nucleus.
  6610.  
  6611.        ConditionTreeWalker ( Conditions , NumberOfConditions ) ;
  6612.  
  6613.  
  6614.        -- A record is fetched.
  6615.  
  6616.        R8FECH ( FileNumber , CountVariable , RetrievalStrategy ,
  6617.                 NumberOfConditions , Level , SizeOfRecord , StartOfRecord ,
  6618.                 MAILBOX ) ;
  6619.  
  6620.  
  6621.  
  6622.        -- CountVariable also acts as an error return.
  6623.  
  6624.        if CountVariable < -1
  6625.           then raise RAPPORT_ERROR ;
  6626.        end if ;
  6627.  
  6628.  
  6629.        -- If a record is found then CountVariable will indiacte it and so will
  6630.        -- be greater than 0.
  6631.  
  6632.        EXISTS := (CountVariable > 0 ) ;
  6633.  
  6634.      else
  6635.  
  6636.        ERROR_CODE := -100 ;
  6637.        raise RAPPORT_ERROR ;
  6638.  
  6639.      end if ;
  6640.  
  6641.  
  6642. --     PUT("%ADALIB-TRACEMSG-LEAVING PROCEDURE FETCH") ; NEW_LINE ;
  6643.  
  6644.    end FETCH ;
  6645.  
  6646.  
  6647.  
  6648.  
  6649.  
  6650.  
  6651.    procedure DELETE(NUMBER : out integer ;
  6652.                     CONDITIONS : CONDITION_TREE) is
  6653.  
  6654.  
  6655. -------------------------------------------------------------------------------
  6656. --
  6657. -- Function        : This procedure deletes all records from the file that
  6658. --                   satisfy the inputed conditions.
  6659. --
  6660. -- Input arguments : CONDITIONS : A poinetr indicating the condition tree.
  6661. --
  6662. -- Output arguments: NUMBER : The number of records deleted in the delete.
  6663. --
  6664. -- Global variables: RAPPORT.MAILBOX , FileNumber .
  6665. --
  6666. -- Calls to        : ConditionTreewalker , R8LIB.R8DELT.
  6667. --
  6668. -- Called by       : ADA Application program .
  6669. --
  6670. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  6671. --
  6672. -- Amendments      :                        (  /  /  )
  6673. --
  6674. -- Notes           : 
  6675. --
  6676. -------------------------------------------------------------------------------
  6677.  
  6678.  
  6679.  
  6680.  
  6681.    NumberOfConditions : long_integer ;
  6682.    NumberDeleted : long_integer ;
  6683.  
  6684.    begin
  6685.  
  6686. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE DELETE") ; NEW_LINE ;
  6687.  
  6688.      if RAPPORT_STARTED then
  6689.  
  6690.        -- Send the conditions to the nucleus.
  6691.  
  6692.        ConditionTreeWalker ( CONDITIONS , NumberOfConditions ) ;
  6693.  
  6694.  
  6695.        R8DELT ( FileNumber , NumberDeleted , NumberOfConditions ,
  6696.                 MAILBOX ) ;
  6697.  
  6698.        Number := integer ( NumberDeleted ) ;
  6699.  
  6700.  
  6701.      else
  6702.  
  6703.        ERROR_CODE := -100 ;
  6704.        raise RAPPORT_ERROR ;
  6705.  
  6706.      end if ;
  6707.  
  6708. --     put("%ADALIB-TRACEMSG-LEAVING PROCEDURE DELETE") ; NEW_LINE ;
  6709.  
  6710.    end DELETE ;
  6711.  
  6712.  
  6713.  
  6714.  
  6715.  
  6716.    procedure SET_SELECTOR(SELECTION : out SELECTOR) is
  6717.  
  6718.  
  6719. -------------------------------------------------------------------------------
  6720. --
  6721. -- Function        : This procedure sets a selector when there are no condition
  6722. --                   on the search.
  6723. --
  6724. -- Input arguments : None .
  6725. --
  6726. -- Output arguments: SELECTION : A selector to use in a search.
  6727. --
  6728. -- Global variables: RAPPORT.MAILBOX , FileNumber , SELECTOR_STACK .
  6729. --                   CURRENT_LEVEL , MAX_STACK_SIZE .
  6730. --
  6731. -- Calls to        : None.
  6732. --
  6733. -- Called by       : ADA Application program.
  6734. --
  6735. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  6736. --
  6737. -- Amendments      :                        (  /  /  )
  6738. --
  6739. -- Notes           : 
  6740. --
  6741. -------------------------------------------------------------------------------
  6742.  
  6743.  
  6744.  
  6745.    begin
  6746.  
  6747.      if RAPPORT_STARTED then
  6748.  
  6749.        -- we must first check that the searches have not been nested too deep
  6750.  
  6751.        if CURRENT_LEVEL >= MAX_STACK_SIZE
  6752.      
  6753.           then ERROR_CODE := -30 ;
  6754.                raise RAPPORT_ERROR ;
  6755.  
  6756.           else CURRENT_LEVEL := CURRENT_LEVEL+1 ;
  6757.                SELECTOR_STACK( CURRENT_LEVEL ) := NORMAL ;
  6758.  
  6759.                -- The count variable is set to 0 as no record has yet been 
  6760.                -- fetched.
  6761.  
  6762.                SELECTION.CounTVariable := 0 ;
  6763.  
  6764.                -- The retrieval strategy is set to 0 as none has been decided
  6765.                -- upon.
  6766.  
  6767.                SELECTION.RetrievalStrategy := 0 ;
  6768.                SELECTION.Level := CURRENT_LEVEL ;
  6769.                SELECTION.Conditions := null ;
  6770.  
  6771.        end if ;
  6772.  
  6773.     
  6774.      else
  6775.  
  6776.        ERROR_CODE := -100 ;
  6777.        raise RAPPORT_ERROR ;
  6778.  
  6779.      end if ;      
  6780.  
  6781.  
  6782.    end SET_SELECTOR ;
  6783.  
  6784.  
  6785.  
  6786.  
  6787.  
  6788.    procedure SET_SELECTOR(SELECTION : out SELECTOR;
  6789.                           CONDITIONS : CONDITION_TREE) is
  6790.  
  6791.  
  6792. -------------------------------------------------------------------------------
  6793. --
  6794. -- Function        : This procedure sets a selector when there are conditions
  6795. --                   on the search.
  6796. --
  6797. -- Input arguments : CONDITIONS : The conditions that are to be imposed on the
  6798. --                                search.
  6799. --
  6800. -- Output arguments: SELECTION : A selector to use in a search.
  6801. --
  6802. -- Global variables: RAPPORT.MAILBOX , FileNumber , SELECTOR_STACK .
  6803. --                   CURRENT_LEVEL , MAX_STACK_SIZE .
  6804. --
  6805. -- Calls to        : None .
  6806. --
  6807. -- Called by       : ADA Application program.
  6808. --
  6809. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  6810. --
  6811. -- Amendments      :                        (  /  /  )
  6812. --
  6813. -- Notes           : 
  6814. --
  6815. -------------------------------------------------------------------------------
  6816.  
  6817.  
  6818.    begin
  6819.  
  6820.  
  6821.      if RAPPORT_STARTED then 
  6822.  
  6823.        -- we must first check that the searches have not been nested too deep.
  6824.  
  6825.        if CURRENT_LEVEL >= MAX_STACK_SIZE
  6826.      
  6827.           then ERROR_CODE := -30  ;
  6828.                raise RAPPORT_ERROR ;
  6829.  
  6830.           else CURRENT_LEVEL := CURRENT_LEVEL+1 ;
  6831.                SELECTOR_STACK( CURRENT_LEVEL ) := NORMAL ;
  6832.  
  6833.                -- CoutnVariable is set to 0 as no record has yet been fetched .
  6834.  
  6835.                SELECTION.CounTVariable := 0 ;
  6836.  
  6837.                -- Retrieval strategy is set to 0 has it has not yet been 
  6838.                -- decided.
  6839.  
  6840.                SELECTION.RetrievalStrategy := 0 ;
  6841.                SELECTION.Level := CURRENT_LEVEL ;
  6842.                SELECTION.Conditions := Conditions ;
  6843.  
  6844.        end if ;
  6845.  
  6846.  
  6847.      else
  6848.  
  6849.        ERROR_CODE := -100 ;
  6850.        raise RAPPORT_ERROR ;
  6851.  
  6852.      end if ;
  6853.  
  6854.  
  6855.    end SET_SELECTOR ;
  6856.  
  6857.  
  6858.  
  6859.  
  6860.  
  6861.    procedure SET_ORDERED(SELECTION : out SELECTOR;
  6862.                          ORDERING : ORDERING_TREE) is
  6863.  
  6864. -------------------------------------------------------------------------------
  6865. --
  6866. -- Function        : Sets a selector for an ordered search where there are no
  6867. --                   conditions applied . The Ordering is transmited to the 
  6868. --                   nucleus which is then requested to make the ordered
  6869. --                   copy of the file which is then used to retrieve from.
  6870. --
  6871. -- Input arguments : ORDERING : A pointer to an order tree specifying the 
  6872. --                   ordering that is to be applied.
  6873. --
  6874. -- Output arguments: SELECTION : A selector to be used in a search.
  6875. --
  6876. -- Global variables: RAPPORT.MAILBOX , FileNumber , RAPPORT.ERROR_CODE .
  6877. --                   SELECTOR_STACK CURRENT_LEVEL , MAX_STACK_SIZE .
  6878. --
  6879. -- Calls to        : R8LIB.R8STKY , R8LIB.R8HOLD , OrderingTreewAlker .
  6880. --
  6881. -- Called by       : ADA Application program .
  6882. --
  6883. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  6884. --
  6885. -- Amendments      :                        (  /  /  )
  6886. --
  6887. -- Notes           : 
  6888. --
  6889. -------------------------------------------------------------------------------
  6890.  
  6891.  
  6892.  
  6893.  
  6894.     OrderList : ORDERING_ARRAY ;
  6895.     NumberOfFieldsInOrdering : integer ;
  6896.     LongNumberInList : long_integer ;
  6897.     NormalRetrieval : long_integer :=0 ;
  6898.     StartAddressOfList : long_integer ;
  6899.     NoConditions : long_integer :=0 ;
  6900.     NumberOfRecords : long_integer ;
  6901.  
  6902.  
  6903.    begin
  6904.  
  6905. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE DET_ORDERED") ; NEW_LINE ;
  6906.  
  6907.      if RAPPORT_STARTED then 
  6908.  
  6909.        -- we must first check that the search nesting is not too great.
  6910.  
  6911.        if CURRENT_LEVEL >= MAX_STACK_SIZE
  6912.  
  6913.           then ERROR_CODE := -30 ;
  6914.                raise RAPPORT_ERROR ;
  6915.      
  6916.           else CURRENT_LEVEL := CURRENT_LEVEL + 1 ;
  6917.                SELECTOR_STACK(CURRENT_LEVEL) := ORDERED ;
  6918.  
  6919.                -- The count variable is set to 0 as no records have yet been 
  6920.                -- retrieved .
  6921.  
  6922.                SELECTION.CountVariable := 0 ;
  6923.  
  6924.                -- Retrieval strategy is set to 0 as none has been decided upon.
  6925.  
  6926.                SELECTION.RetrievalStrategy := 0 ;
  6927.                SELECTION.Level := CURRENT_LEVEL ;
  6928.  
  6929.  
  6930.                -- Collapse the ordering tree into an array representation.
  6931.        
  6932.                OrderingTreeWalker ( Ordering , OrderList , 
  6933.                                     NumberOfFieldsInOrdering);
  6934.  
  6935.  
  6936.          
  6937.  
  6938.                LongNumberInList := long_integer ( NumberOfFieldsInOrdering ) ;
  6939.                StartAddressOfList := 
  6940.                AddressToLongInteger ( OrderList'address ) ;
  6941.  
  6942.                -- Transmit the list to the nucleus
  6943.  
  6944.                R8STKY ( FileNumber , LongNumberInList , StartAddressOfList ,
  6945.                         NormalRetrieval , MAILBOX ) ;
  6946.  
  6947.  
  6948.                -- create an ordered copy of the file on that ordering
  6949.  
  6950.                R8HOLD ( FileNumber , NoConditions , NumberOfRecords ,
  6951.                         MAILBOX ) ;
  6952.  
  6953.           end if ;
  6954.  
  6955.        else
  6956.  
  6957.           ERROR_CODE := -100 ;
  6958.           raise RAPPORT_ERROR ;
  6959.  
  6960.        end if ;
  6961.  
  6962.  
  6963. --       put("%ADALIB-TRACEMSG-LEAVING PROCEDURE DET_ORDERED") ; NEW_LINE ;
  6964.    
  6965.  
  6966.    end SET_ORDERED ;
  6967.  
  6968.  
  6969.  
  6970.  
  6971.  
  6972.    procedure SET_ORDERED(SELECTION : out SELECTOR;
  6973.                          ORDERING : ORDERING_TREE;
  6974.                          CONDITIONS : CONDITION_TREE) is
  6975.  
  6976. -------------------------------------------------------------------------------
  6977. --
  6978. -- Function        : Sets a selector for an ordered search where there are 
  6979. --                   conditions applied . The Ordering is transmited to the 
  6980. --                   nucleus which is then requested to make the ordered
  6981. --                   copy of the file which is then usedc to retrieve from.
  6982. --
  6983. -- Input arguments : ORDERING : A poinetr to an order tree specifying the 
  6984. --                   ordering that is to be applied.
  6985. --                   CONDITIONS : A pointer to the condition tree.
  6986. --
  6987. -- Output arguments: SELECTION : A selector to be used in a search.
  6988. --
  6989. -- Global variables: RAPPORT.MAILBOX , FileNumber , RAPPORT.ERROR_CODE .
  6990. --                   CURRENT_LEVEL , MAX_STACK_SIZE .
  6991. --
  6992. -- Calls to        : R8LIB.R8STKY , R8LIB.R8HOLD , ConditionTreeWalker ,
  6993. --                   Ordering TreeWalker .
  6994. --
  6995. -- Called by       : ADA Application program .
  6996. --
  6997. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  6998. --
  6999. -- Amendments      :                        (  /  /  )
  7000. --
  7001. -- Notes           : 
  7002. --
  7003. -------------------------------------------------------------------------------
  7004.  
  7005.  
  7006.  
  7007.     OrderList : ORDERING_ARRAY ;
  7008.     NumberOfFieldsInOrdering : integer ;
  7009.     LongNumberInList: long_integer ;
  7010.     NormalRetrieval : long_integer :=0 ;
  7011.     StartAddressOfList : long_integer ;
  7012.     NumberOfConditions : long_integer ;
  7013.     NumberOfRecords : long_integer ;
  7014.  
  7015.  
  7016.    begin
  7017.  
  7018. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE DET_ORDERED") ; NEW_LINE ;
  7019.  
  7020.  
  7021.      if RAPPORT_STARTED then
  7022.  
  7023.        -- We must first check that the search nesting is not too deep
  7024.  
  7025.        if CURRENT_LEVEL >= MAX_STACK_SIZE
  7026.  
  7027.           then ERROR_CODE := -30 ;
  7028.                raise RAPPORT_ERROR ;
  7029.      
  7030.           else CURRENT_LEVEL := CURRENT_LEVEL + 1 ;
  7031.                SELECTOR_STACK(CURRENT_LEVEL) := ORDERED ;
  7032.  
  7033.  
  7034.                -- The count variable is set to 0 as no record has yet been
  7035.                -- retrieved .
  7036.  
  7037.                SELECTION.CountVariable := 0 ;
  7038.  
  7039.  
  7040.                -- The retrieval strategy is set to 0 as none has yet been 
  7041.                -- decided upon.
  7042.  
  7043.                SELECTION.RetrievalStrategy := 0 ;
  7044.                SELECTION.Level := CURRENT_LEVEL ;
  7045.  
  7046.                OrderingTreeWalker ( Ordering , OrderList , 
  7047.                                     NumberOfFieldsInOrdering);
  7048.  
  7049.  
  7050.                LongNumberInList := long_integer ( NumberOfFieldsInOrdering ) ;
  7051.                StartAddressOfList := 
  7052.                AddressToLongInteger ( OrderList'address ) ;
  7053.  
  7054.  
  7055.                -- Transmit the ordering to the nucleus.
  7056.  
  7057.                R8STKY ( FileNumber , LongNumberInList , StartAddressOfList ,
  7058.                         NormalRetrieval , MAILBOX ) ;
  7059.  
  7060.                -- Transmit the conditions to the nucleus.
  7061.  
  7062.                ConditionTreeWalker ( Conditions , NumberOfConditions ) ;
  7063.  
  7064.                -- Create an ordered copy of the file.
  7065.  
  7066.                R8HOLD ( FileNumber , NumberOfConditions , NumberOfRecords ,
  7067.                         MAILBOX ) ;
  7068.  
  7069.           end if ;
  7070.  
  7071.         else
  7072.  
  7073.           ERROR_CODE := -100 ;
  7074.           raise RAPPORT_ERROR ;
  7075.  
  7076.         end if ;
  7077.  
  7078.  
  7079. --       put("%ADALIB-TRACEMSG-LEAVING PROCEDURE DET_ORDERED") ; NEW_LINE ;
  7080.    
  7081.    end SET_ORDERED ;
  7082.  
  7083.  
  7084.  
  7085.  
  7086.    procedure SET_UNIQUE(SELECTION : out SELECTOR;
  7087.                         ORDERING : ORDERING_TREE) is
  7088.  
  7089. -------------------------------------------------------------------------------
  7090. --
  7091. -- Function        : Sets a selector for an ordered search where there are no 
  7092. --                   conditions applied . The Ordering is transmited to the 
  7093. --                   nucleus which is then requested to make the ordered
  7094. --                   copy of the file which is then usedc to retrieve from.
  7095. --                   The difference with a unique search is that only one
  7096. --                   record matching the ordering is copied to the order.
  7097. --
  7098. -- Input arguments : ORDERING : A poinetr to an order tree specifying the 
  7099. --                   ordering that is to be applied.
  7100. --
  7101. -- Output arguments: SELECTION : A selector to be used in a search.
  7102. --
  7103. -- Global variables: RAPPORT.MAILBOX , FileNumber , RAPPORT.ERROR_CODE .
  7104. --                   SELECTOR_STACK , CURRENT_LEVEL , MAX_STACK_SIZE .
  7105. --
  7106. -- Calls to        : R8LIB.R8STKY , R8LIB.R8HOLD ,
  7107. --                   Ordering TreeWalker .
  7108. --
  7109. -- Called by       : ADA Application program .
  7110. --
  7111. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  7112. --
  7113. -- Amendments      :                        (  /  /  )
  7114. --
  7115. -- Notes           : 
  7116. --
  7117. -------------------------------------------------------------------------------
  7118.  
  7119.  
  7120.  
  7121.     OrderList : ORDERING_ARRAY ;
  7122.     NumberOfFieldsInOrdering : integer ;
  7123.     LongNumberInList : long_integer ;
  7124.     UniqueRetrieval : long_integer :=1 ;
  7125.     StartAddressOfList : long_integer ;
  7126.     NoConditions : long_integer :=0 ;
  7127.     NumberOfRecords : long_integer ;
  7128.  
  7129.  
  7130.    begin
  7131.  
  7132. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE DET_UNIQUED") ; NEW_LINE ;
  7133.  
  7134.      if RAPPORT_STARTED then
  7135.  
  7136.        -- we must first check that the ordering is not too deep.
  7137.  
  7138.        if CURRENT_LEVEL >= MAX_STACK_SIZE
  7139.  
  7140.           then ERROR_CODE := -30 ;
  7141.                raise RAPPORT_ERROR ;
  7142.      
  7143.           else CURRENT_LEVEL := CURRENT_LEVEL + 1 ;
  7144.                SELECTOR_STACK(CURRENT_LEVEL) := UNIQUE ;
  7145.  
  7146.  
  7147.                -- The count variable is set to 0 as no record has yet been
  7148.                -- fetched.
  7149.  
  7150.                SELECTION.CountVariable := 0 ;
  7151.                SELECTION.RetrievalStrategy := 0 ;
  7152.                SELECTION.Level := CURRENT_LEVEL ;
  7153.  
  7154.                OrderingTreeWalker ( Ordering , OrderList , 
  7155.                                     NumberOfFieldsInOrdering);
  7156.  
  7157.  
  7158.                LongNumberInList := long_integer ( NumberOfFieldsInOrdering ) ;
  7159.                StartAddressOfList := 
  7160.                AddressToLongInteger ( OrderList'address ) ;
  7161.  
  7162.  
  7163.                -- transmit the ordering to the nucleus .
  7164.  
  7165.                R8STKY ( FileNumber , LongNumberInList , StartAddressOfList ,
  7166.                         UniqueRetrieval , MAILBOX ) ;
  7167.  
  7168.  
  7169.              -- make an   ordered copy of the file .
  7170.  
  7171.              R8HOLD ( FileNumber , NoConditions , NumberOfRecords ,
  7172.                       MAILBOX ) ;
  7173.  
  7174.           end if ;
  7175.  
  7176.         else
  7177.  
  7178.           ERROR_CODE := -100 ;
  7179.           raise RAPPORT_ERROR ;
  7180.  
  7181.         end if ;
  7182.  
  7183. --       put("%ADALIB-TRACEMSG-LEAVING PROCEDURE DET_UNIQUE") ; NEW_LINE ;
  7184.    
  7185.  
  7186.    end SET_UNIQUE ;
  7187.  
  7188.  
  7189.  
  7190.  
  7191.    procedure SET_UNIQUE(SELECTION : out SELECTOR;
  7192.                         ORDERING : ORDERING_TREE;
  7193.                         CONDITIONS : CONDITION_TREE) is
  7194.  
  7195. -------------------------------------------------------------------------------
  7196. --
  7197. -- Function        : Sets a selector for an ordered search where there are no 
  7198. --                   conditions applied . The Ordering is transmited to the 
  7199. --                   nucleus which is then requested to make the ordered
  7200. --                   copy of the file which is then usedc to retrieve from.
  7201. --                   The difference with a unique search is that only one
  7202. --                   record matching the ordering is copied to the order.
  7203. --
  7204. -- Input arguments : ORDERING : A poinetr to an order tree specifying the 
  7205. --                   ordering that is to be applied.
  7206. --
  7207. -- Output arguments: SELECTION : A selector to be used in a search.
  7208. --
  7209. -- Global variables: RAPPORT.MAILBOX , FileNumber , RAPPORT.ERROR_CODE .
  7210. --                   SELECTOR_STACK , CURRENT_LEVEL , MAX_STACK_SIZE .
  7211. --
  7212. -- Calls to        : R8LIB.R8STKY , R8LIB.R8HOLD , ConditionTreeWalker
  7213. --                   Ordering TreeWalker .
  7214. --
  7215. -- Called by       : ADA Application program .
  7216. --
  7217. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  7218. --
  7219. -- Amendments      :                        (  /  /  )
  7220. --
  7221. -- Notes           : 
  7222. --
  7223. -------------------------------------------------------------------------------
  7224.  
  7225.  
  7226.     OrderList : ORDERING_ARRAY ;
  7227.     NumberOfFieldsInOrdering : integer ;
  7228.     LongNumberInList : long_integer ;
  7229.     UniqueRetrieval : long_integer :=1 ;
  7230.     StartAddressOfList : long_integer ;
  7231.     NumberOfConditions : long_integer ;
  7232.     NumberOfRecords : long_integer ;
  7233.  
  7234.  
  7235.    begin
  7236.  
  7237. --     put("%ADALIB-TRACEMSG-ENTERING PROCEDURE DET_UNIQUE") ; NEW_LINE ;
  7238.  
  7239.  
  7240.      if RAPPORT_STARTED then 
  7241.  
  7242.        -- wee must first check that we are not overloading the stack .
  7243.  
  7244.        if CURRENT_LEVEL >= MAX_STACK_SIZE
  7245.  
  7246.           then ERROR_CODE := -30 ;
  7247.                raise RAPPORT_ERROR ;
  7248.      
  7249.           else CURRENT_LEVEL := CURRENT_LEVEL + 1 ;
  7250.                SELECTOR_STACK(CURRENT_LEVEL) := UNIQUE ;
  7251.  
  7252.                -- count is set to 0 to indicate the first fetch .
  7253.  
  7254.                SELECTION.CountVariable := 0 ;
  7255.                SELECTION.RetrievalStrategy := 0 ;
  7256.                SELECTION.Level := CURRENT_LEVEL ;
  7257.  
  7258.                OrderingTreeWalker ( Ordering , OrderList , 
  7259.                                     NumberOfFieldsInOrdering);
  7260.  
  7261.  
  7262.  
  7263.  
  7264.                LongNumberInList := long_integer ( NumberOfFieldsInOrdering ) ;
  7265.                StartAddressOfList := 
  7266.                AddressToLongInteger ( OrderList'address ) ;
  7267.  
  7268.  
  7269.                -- transmit the ordering to the nucleus
  7270.  
  7271.                R8STKY ( FileNumber , LongNumberInList , StartAddressOfList ,
  7272.                         UniqueRetrieval , MAILBOX ) ;
  7273.  
  7274.      
  7275.                -- transmit the conditions to the nucleus .
  7276.  
  7277.                ConditionTreeWalker ( Conditions , NumberOfConditions ) ;
  7278.              
  7279.  
  7280.                -- make an ordered copy of the file
  7281.  
  7282.                R8HOLD ( FileNumber , NumberOfConditions , NumberOfRecords ,
  7283.                         MAILBOX ) ;
  7284.  
  7285.           end if ;
  7286.  
  7287.         else
  7288.  
  7289.           ERROR_CODE := -100 ;
  7290.           raise RAPPORT_ERROR ;
  7291.  
  7292.         end if ;
  7293.  
  7294.  
  7295. --       put("%ADALIB-TRACEMSG-LEAVING PROCEDURE DET_UNIQUE") ; NEW_LINE ;
  7296.    
  7297.    end SET_UNIQUE ;
  7298.  
  7299.  
  7300.  
  7301.  
  7302.  
  7303.    procedure SEARCH(SELECTION : in out SELECTOR;
  7304.                     REC : out DB_RECORD;
  7305.                     END_OF_SEARCH : out BOOLEAN) is
  7306.  
  7307.  
  7308. -------------------------------------------------------------------------------
  7309. --
  7310. -- Function        : This procedure given a selector returns a record from
  7311. --                   the file . The count variable in the selector is
  7312. --                   updated on each search ( The retrieval strategy is updated
  7313. --                   only on the first ) so that the next record on is returned
  7314. --                   on each search in a set .
  7315. --                      The termination of the search occurrs when the count
  7316. --                   returned from the nucleus is -1 . ( Note that the count
  7317. --                   also acts as an error code as it can take negative values
  7318. --                   which => error .
  7319. --                      There are two main types of search , one done on acopy
  7320. --                   of the file (ORDERED , UNIQUE ) and one done on the file
  7321. --                   itself ( NORMAL ) .These require different strategies .
  7322. --                   A normal search has to transmit the conditions to the
  7323. --                   nucleus before performing a fetch but an ordered or unique
  7324. --                   search does not as the conditions have already been 
  7325. --                   performed on the copy file .
  7326. --                     
  7327. --
  7328. -- Input arguments : SELECTION : which details information relevant to the 
  7329. --                   search ( Count , Retrieval , Conditions ,type )
  7330. --
  7331. -- Output arguments: REC : the database record got from the file.
  7332. --                   END_OF_SEARCH : a boolean which is true if the count 
  7333. --                   variable is returned as -1 .
  7334. --
  7335. -- Global variables: RAPPORT.MAILBOX , FileNumber , CURRENT_LEVEL , 
  7336. --                   SELECTION_STACK , CURRENT_LEVEL  .
  7337. --
  7338. -- Calls to        : R8LIB.R8FECH , R8LIB.R8RTRV , ConditionTreeWalker .
  7339. --                   RAPPORT.AddressToLongInteger
  7340. --
  7341. -- Called by       : ADA Application program .
  7342. --
  7343. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  7344. --
  7345. -- Amendments      :                        (  /  /  )
  7346. --
  7347. -- Notes           : 
  7348. --
  7349. -------------------------------------------------------------------------------
  7350.  
  7351.  
  7352.    Selector_Stack_Level : integer ;
  7353.    StartOfRecord : long_integer ;
  7354.    SizeOfRecord : long_integer ;
  7355.    NumberOfConditions : long_integer ;
  7356.    DummyLevel : long_integer :=0 ;
  7357.  
  7358.  
  7359.    begin
  7360.  
  7361.  
  7362.      if RAPPORT_STARTED then 
  7363.  
  7364.        -- there are two groups of search pattern NORMAL & otherwise
  7365.  
  7366.        if SELECTOR_STACK ( SELECTION.Level ) /= NORMAL
  7367.  
  7368.           -- in the case of a non-noramal search we are working with an
  7369.           -- ordered copy of the file . To ensure that this has not been
  7370.           -- subsequently overwritten we must ensure that since this search
  7371.           -- was initiated ( with a set_ordered or a set_unique ) no other
  7372.           -- non-normal searches have been requested .
  7373.  
  7374.           then for Selector_Stack_Level in SELECTION.Level+1..CURRENT_LEVEL 
  7375.                    loop
  7376.                        if SELECTOR_STACK(Selector_Stack_Level) /= NORMAL
  7377.                           then ERROR_CODE := -10000 ;
  7378.                                raise RAPPORT_ERROR ;
  7379.                        end if ;
  7380.                     end loop ;
  7381.  
  7382.                 StartOfRecord := AddressToLongInteger(REC'address) ;
  7383.                 SizeOfRecord := 
  7384.                 long_integer( DB_RECORD'size/NumberOfBitsInAByte) ;
  7385.  
  7386.  
  7387.                 -- to get a record from the copy file a retrieve , as opposed
  7388.                 -- to a fetch must be performed .
  7389.  
  7390.                 R8RTRV(FileNumber , SELECTION.CountVariable , 
  7391.                        SizeOfRecord , StartOfRecord , MAILBOX ) ;
  7392.  
  7393.  
  7394.                 -- note here how the CountVariable is acting also as an 
  7395.                 -- error code .
  7396.  
  7397.                 if SELECTION.CountVariable < -1
  7398.                    then raise RAPPORT_ERROR ;
  7399.                 end if ;
  7400.  
  7401.  
  7402.                 End_Of_SEARCH := (SELECTION.CountVariable = -1 ) ;
  7403.  
  7404.  
  7405.            -- here we have a normal search and as this does not use a copy file
  7406.            -- we need do no checking.
  7407.  
  7408.            else StartOfRecord := AddressToLongInteger(REC'address) ;
  7409.                 SizeOfRecord := 
  7410.                 long_integer( DB_RECORD'size/NumberOfBitsInAByte) ;
  7411.  
  7412.  
  7413.                 -- note that on each fetch in the search set we must send the
  7414.                 -- conditions on the search to the nucleus . This is because
  7415.                 -- there is no copy file and so the conditions are not stored
  7416.                 -- in the nucleus .
  7417.  
  7418.                 ConditionTreeWalker (SELECTION.Conditions , 
  7419.                                      NumberOfConditions);
  7420.         
  7421.  
  7422.                 R8FECH ( FileNumber , SELECTION.CountVariable ,
  7423.                          SELECTION.RetrievalStrategy ,
  7424.                          NumberOfConditions ,
  7425.                          DummyLevel ,
  7426.                          SizeOfRecord ,
  7427.                          StartOfRecord ,
  7428.                          MAILBOX ) ;
  7429.  
  7430.  
  7431.                 -- count is also used as an error return .
  7432.  
  7433.                 if SELECTION.CountVariable < -1
  7434.                    then raise RAPPORT_ERROR ;
  7435.                 end if ;
  7436.  
  7437.  
  7438.                 End_Of_SEARCH := (SELECTION.CountVariable = -1 ) ;
  7439.  
  7440.                     
  7441.       end if; 
  7442.  
  7443.  
  7444.     else
  7445.  
  7446.       ERROR_CODE := -100 ;
  7447.       raise RAPPORT_ERROR ;
  7448.    
  7449.     end if ;  
  7450.  
  7451.  
  7452.    end SEARCH ;
  7453.  
  7454.  
  7455.  
  7456.  
  7457.  
  7458.    procedure CLEAR_SELECTOR(SELECTION : in out SELECTOR) is
  7459.  
  7460. -------------------------------------------------------------------------------
  7461. --
  7462. -- Function        : After a search is completed the selector used in that
  7463. --                   search must be cleared so that it cannot be re-used .
  7464. --
  7465. -- Input arguments : SELECTION : the selector used in the previous search .
  7466. --
  7467. -- Output arguments: SELECTION : a cleared and unusable selector .
  7468. --
  7469. -- Global variables: CURRENT_LEVEL .
  7470. --
  7471. -- Calls to        : None .
  7472. --
  7473. -- Called by       : ADA Application program .
  7474. --
  7475. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  7476. --
  7477. -- Amendments      :                        (  /  /  )
  7478. --
  7479. -- Notes           : 
  7480. --
  7481. -------------------------------------------------------------------------------
  7482.  
  7483.  
  7484.  
  7485.    begin
  7486.  
  7487.    
  7488.      if RAPPORT_STARTED then
  7489.  
  7490.        -- it is only possible to clear the current level as the integrity of 
  7491.        -- the selector_stack has to be preserved . 
  7492.  
  7493.        if SELECTION.Level /= CURRENT_LEVEL
  7494.  
  7495.           then ERROR_CODE := -10001 ;
  7496.                raise RAPPORT_ERROR ;
  7497.  
  7498.           else if SELECTOR_STACK(SELECTION.Level) /= NORMAL
  7499.  
  7500.                   -- if the search was not normal then we must inform the
  7501.                   -- nucleus that it can get rid of the ordered copy .
  7502.  
  7503.                   then R8ENRV ( SELECTION.CountVariable , ERROR_CODE , MAILBOX) ;
  7504.                 
  7505.                end if ;
  7506.  
  7507.                if ERROR_CODE <-1 
  7508.                   then raise RAPPORT_ERROR ;
  7509.                end if ;
  7510.  
  7511.  
  7512.                -- the current level in the stack is decremented .
  7513.  
  7514.                CURRENT_LEVEL := CURRENT_LEVEL-1 ;
  7515.  
  7516.  
  7517.                -- in either search case the selection parameters must be made
  7518.                -- unusable . ( if count = -1 then no search can take place
  7519.                -- as the nucleus will return an error .
  7520.  
  7521.                SELECTION.CountVariable := -1 ;
  7522.                SELECTION.Conditions := null ;
  7523.          
  7524.        end if ;
  7525.  
  7526.      else
  7527.  
  7528.        ERROR_CODE := -100 ;
  7529.        raise RAPPORT_ERROR ;
  7530.  
  7531.      end if ;
  7532.  
  7533.  
  7534.    end CLEAR_SELECTOR ;
  7535.  
  7536.  
  7537.  
  7538.  
  7539.    function "and" ( LeftPart , RightPart : CONDITION_TREE ) 
  7540.      
  7541.             return CONDITION_TREE  is
  7542.  
  7543. -------------------------------------------------------------------------------
  7544. --
  7545. -- Function        : This is the and conjunction used in specifying a condition
  7546. --                   set . It takes as input a LeftPart of a condition tree and
  7547. --                   a right part and forms another tree with a root node
  7548. --                   specifying the and is to be done on the left and right 
  7549. --                   parts .
  7550. --
  7551. -- Input arguments : LeftPart : a condition tree pointer ( i.e. a set of 
  7552. --                   conditions in the form of a tree )
  7553. --                   RightPart : a conditiontree pointer .
  7554. --
  7555. -- Output arguments: a condition tree :-
  7556. --
  7557. --                                   < and-node >
  7558. --                                     /      \
  7559. --                                    /        \
  7560. --                               <LeftPart> <RightPart>
  7561. --
  7562. -- Global variables: None .
  7563. --
  7564. -- Calls to        : None .
  7565. --
  7566. -- Called by       : ADA Application program .
  7567. --
  7568. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  7569. --
  7570. -- Amendments      :                        (  /  /  )
  7571. --
  7572. -- Notes           : 
  7573. --
  7574. -------------------------------------------------------------------------------
  7575.  
  7576.  
  7577.  
  7578.    ConjunctionNode : CONDITION_TREE ;
  7579.  
  7580.   
  7581.    begin
  7582.  
  7583. --     put("%ADALIB-TRACEMSG-ENTERING FUNCTION AND") ; NEW_LINE ;
  7584.  
  7585.      ConjunctionNode := new Condition_Block ;
  7586.  
  7587.      ConjunctionNode.BlockType := Conjunction ;
  7588.  
  7589.      -- note that an and node is represented by the nucleus by the number 2
  7590.  
  7591.      ConjunctionNode.ConjunctionNumber := 2 ;
  7592.  
  7593.      ConjunctionNode.LeftPartOfConjunction := LeftPart ;
  7594.      ConjunctionNode.RightPartOfConjunction := RightPart ;
  7595.  
  7596. --     put("%ADALIB-TRACEMSG-LEAVING FUNCTION AND") ; NEW_LINE ;
  7597.  
  7598.      return ConjunctionNode ;
  7599.  
  7600.  end "and" ;    
  7601.  
  7602.  
  7603.  
  7604.  
  7605.    function "or" ( LeftPart , RightPart : CONDITION_TREE ) 
  7606.      
  7607.             return CONDITION_TREE  is
  7608.  
  7609. -------------------------------------------------------------------------------
  7610. --
  7611. -- Function        : This is the or conjunction used in specifying a condition
  7612. --                   set . It takes as input a LeftPart of a condition tree and
  7613. --                   a right part and forms another tree with a root node
  7614. --                   specifying the or is to be done on the left and right 
  7615. --                   parts .
  7616. --
  7617. -- Input arguments : LeftPart : a condition tree pointer ( i.e. a set of 
  7618. --                   conditions in the form of a tree )
  7619. --                   RightPart : a conditiontree pointer .
  7620. --
  7621. -- Output arguments: a condition tree :-
  7622. --
  7623. --                                   < or-node >
  7624. --                                     /      \
  7625. --                                    /        \
  7626. --                               <LeftPart> <RightPart>
  7627. --
  7628. -- Global variables: None .
  7629. --
  7630. -- Calls to        : None .
  7631. --
  7632. -- Called by       : ADA Application program .
  7633. --
  7634. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  7635. --
  7636. -- Amendments      :                        (  /  /  )
  7637. --
  7638. -- Notes           : 
  7639. --
  7640. -------------------------------------------------------------------------------
  7641.  
  7642.  
  7643.  
  7644.  
  7645.    ConjunctionNode : CONDITION_TREE ;
  7646.  
  7647.   
  7648.    begin
  7649.  
  7650. --     put("%ADALIB-TRACEMSG-ENTERING FUNCTION AND") ; NEW_LINE ;
  7651.  
  7652.      ConjunctionNode := new Condition_Block ;
  7653.  
  7654.      ConjunctionNode.BlockType := Conjunction ;
  7655.  
  7656.      -- note that the nucleus identifies an or conjunction with 2
  7657.  
  7658.      ConjunctionNode.ConjunctionNumber := 1 ;
  7659.      ConjunctionNode.LeftPartOfConjunction := LeftPart ;
  7660.      ConjunctionNode.RightPartOfConjunction := RightPart ;
  7661.  
  7662. --     put("%ADALIB-TRACEMSG-LEAVING FUNCTION AND") ; NEW_LINE ;
  7663.  
  7664.      return ConjunctionNode ;
  7665.  
  7666.  end "or" ;    
  7667.    
  7668.  
  7669.  
  7670.  
  7671.  
  7672.  function "&" ( LeftPart , RightPart  : ORDERING_TREE )
  7673.           
  7674.           return ORDERING_TREE is
  7675.  
  7676. -------------------------------------------------------------------------------
  7677. --
  7678. -- Function        : This is the function used to group together individual
  7679. --                   pieces of ordering information to form an oredering set .
  7680. --
  7681. -- Input arguments : LeftPart , RightPart : These are sets of one or more
  7682. --                   pieces of ordering information .
  7683. --
  7684. -- Output arguments: an ordering set comprising the two input orderings .
  7685. --
  7686. -- Global variables: None .
  7687. --
  7688. -- Calls to        : None .
  7689. --
  7690. -- Called by       : ADA Application  program .
  7691. --
  7692. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  7693. --
  7694. -- Amendments      :                        (  /  /  )
  7695. --
  7696. -- Notes           : 
  7697. --
  7698. -------------------------------------------------------------------------------
  7699.  
  7700.  
  7701.  
  7702.   TempOrderBlock : ORDERING_TREE ;
  7703.  
  7704.   begin
  7705.  
  7706. --    put("%ADALIB-TRACEMSG-ENTERING PROCEDURE &") ; NEW_LINE ;
  7707.  
  7708.     TempOrderBlock := new ORDER_BLOCK ;
  7709.    
  7710.     TempOrderBlock.BlockType := NODE ;
  7711.     TempOrderBlock.LeftPart := LeftPart ;
  7712.     TempOrderBlock.RightPart := RightPart ;
  7713.  
  7714. --    put("%ADALIB-TRACEMSG-LEAVING PROCEDURE &") ; NEW_LINE ;
  7715.  
  7716.     return TempOrderBlock ;
  7717.  
  7718.   end  "&" ;
  7719.  
  7720.  
  7721.  
  7722.  
  7723. end ;
  7724. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  7725. --GACOND.TXT
  7726. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  7727. -----------------------------------------------------------------------
  7728. --                                                                   --
  7729. -- This is a generic package for the conditions on and ordering of   --
  7730. -- an array field.                                                   --
  7731. -- The package must be hand instantiated as follows :-               --
  7732. --                                                                   --
  7733. --         Replace   %1  with the name of the package with the       --
  7734. --                       file information .                          --
  7735. --                                                                   --
  7736. --         Replace   %2  with the type of the field declared in      --
  7737. --                       the package specified above.                --
  7738. --                                                                   --
  7739. --         replace   %3  with the number of the absolute number of   --
  7740. --                       the field .                                 --
  7741. --                                                                   --
  7742. --         Replace   %4 with the name of the field specified in      --
  7743. --                       the package containing file information.    --
  7744. --                       This then will become the name of the       --
  7745. --                       package .                                   --
  7746. --                                                                   --
  7747. --         Replace   %5 with the type name of an individual element  --
  7748. --                      of a field.                                  --
  7749. --                                                                   --
  7750. --         Replace   %6  with the name of theddf package             --
  7751. --                                                                   --
  7752. --                                                                   --
  7753. --         Finally exit the package as %4.txt and compile it         --
  7754. --                                                                   --
  7755. -----------------------------------------------------------------------
  7756.  
  7757.  
  7758.  
  7759. with %6 , %1 ; use %6 , %1 ;
  7760. with UNCHECKED_CONVERSION ;
  7761.  
  7762.  
  7763. package %4 is
  7764.  
  7765.  
  7766.  
  7767.     function EQUAL ( Value : %2 ) 
  7768.         
  7769.              return  CONDITION_TREE ;
  7770.  
  7771.  
  7772.  
  7773.  
  7774.     function EQUAL ( Index : integer ;
  7775.                      Value : %5 ) 
  7776.         
  7777.              return  CONDITION_TREE ;
  7778.  
  7779.  
  7780.     function EQUAL ( Index : GENERAL_ELEMENT ;
  7781.                      Value : %5 ) 
  7782.         
  7783.              return  CONDITION_TREE ;
  7784.  
  7785.  
  7786.  
  7787.  
  7788.  
  7789.     function GREATER_EQUAL ( Value : %2 ) 
  7790.         
  7791.              return  CONDITION_TREE ;
  7792.  
  7793.  
  7794.  
  7795.  
  7796.     function GREATER_EQUAL ( Index : integer ;
  7797.                      Value : %5 ) 
  7798.         
  7799.              return  CONDITION_TREE ;
  7800.  
  7801.  
  7802.     function GREATER_EQUAL ( Index : GENERAL_ELEMENT ;
  7803.                      Value : %5 ) 
  7804.         
  7805.              return  CONDITION_TREE ;
  7806.  
  7807.  
  7808.  
  7809.  
  7810.  
  7811.     function GREATER_THAN ( Value : %2 ) 
  7812.         
  7813.              return  CONDITION_TREE ;
  7814.  
  7815.  
  7816.  
  7817.  
  7818.     function GREATER_THAN ( Index : integer ;
  7819.                      Value : %5 ) 
  7820.         
  7821.              return  CONDITION_TREE ;
  7822.  
  7823.  
  7824.     function GREATER_THAN ( Index : GENERAL_ELEMENT ;
  7825.                      Value : %5 ) 
  7826.         
  7827.              return  CONDITION_TREE ;
  7828.  
  7829.  
  7830.  
  7831.  
  7832.  
  7833.     function LESS_EQUAL ( Value : %2 ) 
  7834.         
  7835.              return  CONDITION_TREE ;
  7836.  
  7837.  
  7838.  
  7839.  
  7840.     function LESS_EQUAL ( Index : integer ;
  7841.                      Value : %5 ) 
  7842.         
  7843.              return  CONDITION_TREE ;
  7844.  
  7845.  
  7846.     function LESS_EQUAL ( Index : GENERAL_ELEMENT ;
  7847.                      Value : %5 ) 
  7848.         
  7849.              return  CONDITION_TREE ;
  7850.  
  7851.  
  7852.  
  7853.  
  7854.  
  7855.     function LESS_THAN ( Value : %2 ) 
  7856.         
  7857.              return  CONDITION_TREE ;
  7858.  
  7859.  
  7860.  
  7861.  
  7862.     function LESS_THAN ( Index : integer ;
  7863.                      Value : %5 ) 
  7864.         
  7865.              return  CONDITION_TREE ;
  7866.  
  7867.  
  7868.     function LESS_THAN ( Index : GENERAL_ELEMENT ;
  7869.                      Value : %5 ) 
  7870.         
  7871.              return  CONDITION_TREE ;
  7872.  
  7873.  
  7874.  
  7875.  
  7876.  
  7877.     function UNEQUAL ( Value : %2 ) 
  7878.         
  7879.              return  CONDITION_TREE ;
  7880.  
  7881.  
  7882.  
  7883.  
  7884.     function UNEQUAL ( Index : integer ;
  7885.                      Value : %5 ) 
  7886.         
  7887.              return  CONDITION_TREE ;
  7888.  
  7889.  
  7890.     function UNEQUAL ( Index : GENERAL_ELEMENT ;
  7891.                      Value : %5 ) 
  7892.         
  7893.              return  CONDITION_TREE ;
  7894.  
  7895.  
  7896.  
  7897.  
  7898.  
  7899.     function UP return ORDERING_TREE ;
  7900.  
  7901.     function DOWN return ORDERING_TREE ;
  7902.  
  7903.  
  7904. end ;
  7905.  
  7906.  
  7907.  
  7908.  
  7909.  
  7910.  
  7911. package body %4 is
  7912.  
  7913.  
  7914. NumberOfBitsInAByte : constant integer := 8 ;
  7915.  
  7916.  
  7917.  
  7918. -------------------------------------------------------------------------
  7919. -------------------------------------------------------------------------
  7920. --                                                                     --
  7921. --             NOTE ON THE IMPLEMENTATION OF CONDITIONS                --
  7922. --                                                                     --
  7923. --     All of the conditions take the same form .                      --
  7924. --                                                                     --
  7925. --              * A pointer to the type of the field is set up .       --
  7926. --              * It is instantiated and set equal to the RHS of       --
  7927. --                the condition .                                      --
  7928. --              * The address of the pointer is calculated by a        --
  7929. --                function translating from a pointer type to a long   --
  7930. --                integer type .                                       --
  7931. --              * The size of the RHS is the size of the field_type    --
  7932. --              * The start and size of the RHS along with the         --
  7933. --                condition number are stored in the condition tree    --
  7934. --                                                                     --
  7935. --     A pointer type was used to store the value of the RHS of a      --
  7936. -- condition as is the only type that can be used . A local variable   --
  7937. -- (to the function) would dissapear after termination of the function --
  7938. -- Pointers live on . A global variable would be unsuitable as it is   --
  7939. -- not known at compile time the amount of conditions that are to be   --
  7940. -- set . Pointers are dynamic and so this problem does not arise .     --
  7941. --                                                                     --
  7942. --     In the case here of array field there is more than one type of  --
  7943. -- comparison for each comparison type . All the array can be tested   --
  7944. -- a single named element of the array can be tested or it can be      --
  7945. -- tested for any value of the array . So for each comparison there    --
  7946. -- are three functions . One header is supplied for each set of        --
  7947. -- functions and an individual explanation note for each one .         --
  7948. --                                                                     --
  7949. -------------------------------------------------------------------------
  7950. -------------------------------------------------------------------------
  7951.  
  7952.  
  7953.  
  7954.  
  7955.  
  7956. -------------------------------------------------------------------------------
  7957. --
  7958. -- Function        : To create a condition tree node for the condition EQUAL .
  7959. --                   Note equlaity applied to string fields is true if every
  7960. --                   element of the strings being compared is identical .
  7961. --
  7962. -- Input arguments : Value : The value of the RHS of the condition .
  7963. --
  7964. -- Output arguments: Returns a pointer to the created condition tree node .
  7965. --
  7966. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  7967. --
  7968. -- Calls to        : RightHandSideToLongInteger .
  7969. --
  7970. -- Called by       : ADA Application program .
  7971. --
  7972. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  7973. --
  7974. -- Amendments      :                        (  /  /  )
  7975. --
  7976. -- Notes           : 
  7977. --
  7978. -------------------------------------------------------------------------------
  7979.  
  7980.  
  7981.  
  7982.  
  7983. -- this function is testing all of the array elements are equivalent to the
  7984. -- corresponding elemnts of the comparison value .
  7985.  
  7986.  
  7987.     function EQUAL ( Value : %2 ) 
  7988.         
  7989.              return  CONDITION_TREE is
  7990.  
  7991.  
  7992.     type RightHandSidePointer is access %2 ;
  7993.  
  7994.     function RightHandSideToLongInteger is new
  7995.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  7996.  
  7997.     NewCondition :  CONDITION_TREE ;
  7998.  
  7999.     RightHandSide : RightHandSidePointer ;
  8000.  
  8001.  
  8002.     begin
  8003.  
  8004.       RightHandSide := new %2 ;
  8005.       RightHandSide.all := Value ;
  8006.  
  8007.  
  8008.  
  8009.  
  8010.       -- create a new condition block and set parameter values .
  8011.  
  8012.          -- ConditionNumber = 1 => EQUAL condition .
  8013.          -- FieldNumber = absolute number of the field the package is
  8014.          --               instantiated for .
  8015.          -- AnyAllSwitch = 0 => normal comparison .
  8016.          -- ArraySubscript = 0 => not used as normal comparison .
  8017.          
  8018.  
  8019.  
  8020.       NewCondition := new Condition_Block ;
  8021.       NewCondition.BlockType := Condition ;
  8022.       NewCondition.RHSParameters.ConditionNumber := 1 ;
  8023.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8024.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  8025.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  8026.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8027.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  8028.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8029.            RightHandSideToLongInteger ( RightHandSide ) ;
  8030.  
  8031.  
  8032.       return NewCondition ;
  8033.  
  8034.     end ;
  8035.                    
  8036.  
  8037.  
  8038. -- this function deals with comparison of equality betwwen an individual
  8039. -- named array element and a value .
  8040.  
  8041.  
  8042.     function EQUAL ( Index : integer ;
  8043.                      Value : %5 ) 
  8044.         
  8045.              return  CONDITION_TREE is
  8046.  
  8047.  
  8048.     type RightHandSidePointer is access %5 ;
  8049.  
  8050.     function RightHandSideToLongInteger is new
  8051.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8052.  
  8053.     NewCondition :  CONDITION_TREE ;
  8054.  
  8055.     RightHandSide : RightHandSidePointer ;
  8056.  
  8057.  
  8058.     begin
  8059.  
  8060.       RightHandSide := new %5 ;
  8061.       RightHandSide.all := Value ;
  8062.  
  8063.  
  8064.  
  8065.  
  8066.       -- create a new condition block and set parameter values .
  8067.  
  8068.          -- ConditionNumber = 1 => EQUAL condition .
  8069.          -- FieldNumber = absolute number of the field the package is
  8070.          --               instantiated for .
  8071.          -- AnyAllSwitch = 1 => named array element comparison.
  8072.          -- ArraySubscript = Index => Compare array element number Index.
  8073.          
  8074.  
  8075.  
  8076.       NewCondition := new Condition_Block ;
  8077.       NewCondition.BlockType := Condition ;
  8078.       NewCondition.RHSParameters.ConditionNumber := 1 ;
  8079.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8080.       NewCondition.RHSParameters.AnyAllSwitch := 1 ;
  8081.       NewCondition.RHSParameters.ArraySubscript := long_integer( index ) ;
  8082.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8083.                    long_integer ( %5'size/NumberOfBitsInAByte ) ;
  8084.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8085.            RightHandSideToLongInteger ( RightHandSide ) ;
  8086.  
  8087.       return NewCondition ;
  8088.  
  8089.     end ;
  8090.                    
  8091.  
  8092.  
  8093.  
  8094.  
  8095. -- this function tests either ALL_ELEMENTS of the array against the value
  8096. -- or to see if ANY_ELEMENT EQUAL to the value .
  8097.  
  8098.  
  8099.     function EQUAL ( Index : GENERAL_ELEMENT ;
  8100.                      Value : %5 ) 
  8101.         
  8102.              return  CONDITION_TREE is
  8103.  
  8104.  
  8105.     type RightHandSidePointer is access %5 ;
  8106.  
  8107.     function RightHandSideToLongInteger is new
  8108.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8109.  
  8110.     NewCondition :  CONDITION_TREE ;
  8111.  
  8112.     RightHandSide : RightHandSidePointer ;
  8113.  
  8114.  
  8115.     begin
  8116.  
  8117.       RightHandSide := new %5 ;
  8118.       RightHandSide.all := Value ;
  8119.  
  8120.  
  8121.  
  8122.  
  8123.       -- create a new condition block and set parameter values .
  8124.  
  8125.          -- ConditionNumber = 1 => EQUAL condition .
  8126.          -- FieldNumber = absolute number of the field the package is
  8127.          --               instantiated for .
  8128.          -- AnyAllSwitch = -1 or -2 => ANY_ELEMENT or ALL_ELEMENTS .
  8129.          -- ArraySubscript = 0 => not applicable to this condition.
  8130.          
  8131.  
  8132.  
  8133.       NewCondition := new Condition_Block ;
  8134.       NewCondition.BlockType := Condition ;
  8135.       NewCondition.RHSParameters.ConditionNumber := 1 ;
  8136.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8137.  
  8138.       if Index = Any_Element
  8139.          then NewCondition.RHSParameters.AnyAllSwitch := -2 ;
  8140.          else NewCondition.RHSParameters.AnyAllSwitch := -1 ;
  8141.       end if ;
  8142.  
  8143.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  8144.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8145.                    long_integer ( %5'size/NumberOfBitsInAByte ) ; 
  8146.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8147.            RightHandSideToLongInteger ( RightHandSide ) ;
  8148.  
  8149.       return NewCondition ;
  8150.  
  8151.     end ;
  8152.                    
  8153.  
  8154.  
  8155. -------------------------------------------------------------------------------
  8156. --
  8157. -- Function        : To create a condition tree node for the condition 
  8158. --                   GREATER_EQUAL . On string fields comparison is by
  8159. --                   dictionary order .
  8160. --
  8161. -- Input arguments : Value : The value of the RHS of the condition .
  8162. --
  8163. -- Output arguments: Returns a pointer to the created condition tree node .
  8164. --
  8165. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  8166. --
  8167. -- Calls to        : RightHandSideToLongInteger .
  8168. --
  8169. -- Called by       : ADA Application program .
  8170. --
  8171. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  8172. --
  8173. -- Amendments      :                        (  /  /  )
  8174. --
  8175. -- Notes           : 
  8176. --
  8177. -------------------------------------------------------------------------------
  8178.  
  8179.  
  8180. -- this function is testing all of the array elements are GREATER_EQUAL to the
  8181. -- corresponding elemnts of the comparison value .
  8182.  
  8183.     function GREATER_EQUAL ( Value : %2 ) 
  8184.         
  8185.              return  CONDITION_TREE is
  8186.  
  8187.  
  8188.     type RightHandSidePointer is access %2 ;
  8189.  
  8190.     function RightHandSideToLongInteger is new
  8191.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8192.  
  8193.     NewCondition :  CONDITION_TREE ;
  8194.  
  8195.     RightHandSide : RightHandSidePointer ;
  8196.  
  8197.  
  8198.     begin
  8199.  
  8200.       RightHandSide := new %2 ;
  8201.       RightHandSide.all := Value ;
  8202.  
  8203.  
  8204.       -- create a new condition block and set parameter values .
  8205.  
  8206.          -- ConditionNumber = 2 => GREATER_EQUAL condition .
  8207.          -- FieldNumber = absolute number of the field the package is
  8208.          --               instantiated for .
  8209.          -- AnyAllSwitch = 0 => normal comparison .
  8210.          -- ArraySubscript = 0 => not used as normal comparison .
  8211.  
  8212.       NewCondition := new Condition_Block ;
  8213.       NewCondition.BlockType := Condition ;
  8214.       NewCondition.RHSParameters.ConditionNumber := 2 ;
  8215.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8216.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  8217.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  8218.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8219.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  8220.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8221.            RightHandSideToLongInteger ( RightHandSide ) ;
  8222.  
  8223.       return NewCondition ;
  8224.  
  8225.     end ;
  8226.                    
  8227.  
  8228.  
  8229. -- this function deals with comparison of GREATER_EQUAL betwwen an individual
  8230. -- named array element and a value .
  8231.  
  8232.  
  8233.     function GREATER_EQUAL ( Index : integer ;
  8234.                      Value : %5 ) 
  8235.         
  8236.              return  CONDITION_TREE is
  8237.  
  8238.  
  8239.     type RightHandSidePointer is access %5 ;
  8240.  
  8241.     function RightHandSideToLongInteger is new
  8242.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8243.  
  8244.     NewCondition :  CONDITION_TREE ;
  8245.  
  8246.     RightHandSide : RightHandSidePointer ;
  8247.  
  8248.  
  8249.     begin
  8250.  
  8251.       RightHandSide := new %5 ;
  8252.       RightHandSide.all := Value ;
  8253.  
  8254.  
  8255.       -- create a new condition block and set parameter values .
  8256.  
  8257.          -- ConditionNumber = 2  => GREATER_EQUAL condition .
  8258.          -- FieldNumber = absolute number of the field the package is
  8259.          --               instantiated for .
  8260.          -- AnyAllSwitch = 1 => named array element comparison.
  8261.          -- ArraySubscript = Index => Compare array element number Index.
  8262.  
  8263.       NewCondition := new Condition_Block ;
  8264.       NewCondition.BlockType := Condition ;
  8265.       NewCondition.RHSParameters.ConditionNumber := 2 ;
  8266.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8267.       NewCondition.RHSParameters.AnyAllSwitch := 1 ;
  8268.       NewCondition.RHSParameters.ArraySubscript := long_integer( index ) ;
  8269.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8270.                    long_integer ( %5'size/NumberOfBitsInAByte ) ;
  8271.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8272.            RightHandSideToLongInteger ( RightHandSide ) ;
  8273.  
  8274.       return NewCondition ;
  8275.  
  8276.     end ;
  8277.                    
  8278.  
  8279.  
  8280.  
  8281.  
  8282. -- this function tests either ALL_ELEMENTS of the array against the value
  8283. -- or to see if ANY_ELEMENT GREATER_EQUAL to the value .
  8284.  
  8285.  
  8286.     function GREATER_EQUAL ( Index : GENERAL_ELEMENT ;
  8287.                      Value : %5 ) 
  8288.         
  8289.              return  CONDITION_TREE is
  8290.  
  8291.  
  8292.     type RightHandSidePointer is access %5 ;
  8293.  
  8294.     function RightHandSideToLongInteger is new
  8295.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8296.  
  8297.     NewCondition :  CONDITION_TREE ;
  8298.  
  8299.     RightHandSide : RightHandSidePointer ;
  8300.  
  8301.  
  8302.     begin
  8303.  
  8304.       RightHandSide := new %5 ;
  8305.       RightHandSide.all := Value ;
  8306.  
  8307.  
  8308.       -- create a new condition block and set parameter values .
  8309.  
  8310.          -- ConditionNumber = 2 => LESS_EQUAL condition .
  8311.          -- FieldNumber = absolute number of the field the package is
  8312.          --               instantiated for .
  8313.          -- AnyAllSwitch = -1 or -2 => ANY_ELEMENT or ALL_ELEMENTS .
  8314.          -- ArraySubscript = 0 => not applicable to this condition .
  8315.  
  8316.       NewCondition := new Condition_Block ;
  8317.       NewCondition.BlockType := Condition ;
  8318.       NewCondition.RHSParameters.ConditionNumber := 2 ;
  8319.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8320.  
  8321.       if Index = Any_Element
  8322.          then NewCondition.RHSParameters.AnyAllSwitch := -2 ;
  8323.          else NewCondition.RHSParameters.AnyAllSwitch := -1 ;
  8324.       end if ;
  8325.  
  8326.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  8327.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8328.                    long_integer ( %5'size/NumberOfBitsInAByte ) ; 
  8329.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8330.            RightHandSideToLongInteger ( RightHandSide ) ;
  8331.  
  8332.       return NewCondition ;
  8333.  
  8334.     end ;
  8335.                    
  8336.  
  8337.  
  8338. -------------------------------------------------------------------------------
  8339. --
  8340. -- Function        : To create a condition tree node for the condition 
  8341. --                   GREATER_THAN . On string fields comparison is by
  8342. --                   dictionary order .
  8343. --
  8344. -- Input arguments : Value : The value of the RHS of the condition .
  8345. --
  8346. -- Output arguments: Returns a pointer to the created condition tree node .
  8347. --
  8348. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  8349. --
  8350. -- Calls to        : RightHandSideToLongInteger .
  8351. --
  8352. -- Called by       : ADA Application program .
  8353. --
  8354. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  8355. --
  8356. -- Amendments      :                        (  /  /  )
  8357. --
  8358. -- Notes           : 
  8359. --
  8360. -------------------------------------------------------------------------------
  8361.  
  8362.  
  8363.  
  8364. -- this function is testing all of the array elements are GREATER_THAN to the
  8365. -- corresponding elemnts of the comparison value .
  8366.  
  8367.  
  8368.     function GREATER_THAN ( Value : %2 ) 
  8369.         
  8370.              return  CONDITION_TREE is
  8371.  
  8372.  
  8373.     type RightHandSidePointer is access %2 ;
  8374.  
  8375.     function RightHandSideToLongInteger is new
  8376.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8377.  
  8378.     NewCondition :  CONDITION_TREE ;
  8379.  
  8380.     RightHandSide : RightHandSidePointer ;
  8381.  
  8382.  
  8383.     begin
  8384.  
  8385.       RightHandSide := new %2 ;
  8386.       RightHandSide.all := Value ;
  8387.  
  8388.  
  8389.       -- create a new condition block and set parameter values .
  8390.  
  8391.          -- ConditionNumber = 3 => GREATER_THAN condition .
  8392.          -- FieldNumber = absolute number of the field the package is
  8393.          --               instantiated for .
  8394.          -- AnyAllSwitch = 0 => normal comparison .
  8395.          -- ArraySubscript = 0 => not used as normal comparison .
  8396.  
  8397.       NewCondition := new Condition_Block ;
  8398.       NewCondition.BlockType := Condition ;
  8399.       NewCondition.RHSParameters.ConditionNumber := 3 ;
  8400.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8401.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  8402.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  8403.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8404.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  8405.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8406.            RightHandSideToLongInteger ( RightHandSide ) ;
  8407.  
  8408.       return NewCondition ;
  8409.  
  8410.     end ;
  8411.                    
  8412.  
  8413.  
  8414. -- this function deals with comparison of GREATER_THAN betwwen an individual
  8415. -- named array element and a value .
  8416.  
  8417.  
  8418.     function GREATER_THAN ( Index : integer ;
  8419.                      Value : %5 ) 
  8420.         
  8421.              return  CONDITION_TREE is
  8422.  
  8423.  
  8424.     type RightHandSidePointer is access %5 ;
  8425.  
  8426.     function RightHandSideToLongInteger is new
  8427.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8428.  
  8429.     NewCondition :  CONDITION_TREE ;
  8430.  
  8431.     RightHandSide : RightHandSidePointer ;
  8432.  
  8433.  
  8434.     begin
  8435.  
  8436.       RightHandSide := new %5 ;
  8437.       RightHandSide.all := Value ;
  8438.  
  8439.  
  8440.       -- create a new condition block and set parameter values .
  8441.  
  8442.          -- ConditionNumber = 3 => GREATER_THAN condition .
  8443.          -- FieldNumber = absolute number of the field the package is
  8444.          --               instantiated for .
  8445.          -- AnyAllSwitch = 1 => named array element comparison.
  8446.          -- ArraySubscript = Index => Compare array element number Index.
  8447.  
  8448.       NewCondition := new Condition_Block ;
  8449.       NewCondition.BlockType := Condition ;
  8450.       NewCondition.RHSParameters.ConditionNumber := 3 ;
  8451.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8452.       NewCondition.RHSParameters.AnyAllSwitch := 1 ;
  8453.       NewCondition.RHSParameters.ArraySubscript := long_integer( index ) ;
  8454.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8455.                    long_integer ( %5'size/NumberOfBitsInAByte ) ;
  8456.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8457.            RightHandSideToLongInteger ( RightHandSide ) ;
  8458.  
  8459.       return NewCondition ;
  8460.  
  8461.     end ;
  8462.                    
  8463.  
  8464.  
  8465.  
  8466.  
  8467.  
  8468. -- this function tests either ALL_ELEMENTS of the array against the value
  8469. -- or to see if ANY_ELEMENT GREATER_THAN to the value .
  8470.  
  8471.  
  8472.     function GREATER_THAN ( Index : GENERAL_ELEMENT ;
  8473.                      Value : %5 ) 
  8474.         
  8475.              return  CONDITION_TREE is
  8476.  
  8477.  
  8478.     type RightHandSidePointer is access %5 ;
  8479.  
  8480.     function RightHandSideToLongInteger is new
  8481.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8482.  
  8483.     NewCondition :  CONDITION_TREE ;
  8484.  
  8485.     RightHandSide : RightHandSidePointer ;
  8486.  
  8487.  
  8488.     begin
  8489.  
  8490.       RightHandSide := new %5 ;
  8491.       RightHandSide.all := Value ;
  8492.  
  8493.  
  8494.       -- create a new condition block and set parameter values .
  8495.  
  8496.          -- ConditionNumber = 3 => GREATER_THAN condition .
  8497.          -- FieldNumber = absolute number of the field the package is
  8498.          --               instantiated for .
  8499.          -- AnyAllSwitch = -1 or -2 => ANY_ELEMENT or ALL_ELEMENTS .
  8500.          -- ArraySubscript = 0 => not applicable to this condition .
  8501.  
  8502.       NewCondition := new Condition_Block ;
  8503.       NewCondition.BlockType := Condition ;
  8504.       NewCondition.RHSParameters.ConditionNumber := 3 ;
  8505.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8506.  
  8507.       if Index = Any_Element
  8508.          then NewCondition.RHSParameters.AnyAllSwitch := -2 ;
  8509.          else NewCondition.RHSParameters.AnyAllSwitch := -1 ;
  8510.       end if ;
  8511.  
  8512.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  8513.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8514.                    long_integer ( %5'size/NumberOfBitsInAByte ) ; 
  8515.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8516.            RightHandSideToLongInteger ( RightHandSide ) ;
  8517.  
  8518.       return NewCondition ;
  8519.  
  8520.     end ;
  8521.                    
  8522.  
  8523.  
  8524. -------------------------------------------------------------------------------
  8525. --
  8526. -- Function        : To create a condition tree node for the condition 
  8527. --                   LESS EQUAL . On string fields comparison is by
  8528. --                   dictionary order .
  8529. --
  8530. -- Input arguments : Value : The value of the RHS of the condition .
  8531. --
  8532. -- Output arguments: Returns a pointer to the created condition tree node .
  8533. --
  8534. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  8535. --
  8536. -- Calls to        : RightHandSideToLongInteger .
  8537. --
  8538. -- Called by       : ADA Application program .
  8539. --
  8540. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  8541. --
  8542. -- Amendments      :                        (  /  /  )
  8543. --
  8544. -- Notes           : 
  8545. --
  8546. -------------------------------------------------------------------------------
  8547.  
  8548.  
  8549.  
  8550. -- this function is testing all of the array elements are LESS_EQUAL to the
  8551. -- corresponding elemnts of the comparison value .
  8552.  
  8553.  
  8554.     function LESS_EQUAL ( Value : %2 ) 
  8555.         
  8556.              return  CONDITION_TREE is
  8557.  
  8558.  
  8559.     type RightHandSidePointer is access %2 ;
  8560.  
  8561.     function RightHandSideToLongInteger is new
  8562.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8563.  
  8564.     NewCondition :  CONDITION_TREE ;
  8565.  
  8566.     RightHandSide : RightHandSidePointer ;
  8567.  
  8568.  
  8569.     begin
  8570.  
  8571.       RightHandSide := new %2 ;
  8572.       RightHandSide.all := Value ;
  8573.  
  8574.  
  8575.       -- create a new condition block and set parameter values .
  8576.  
  8577.          -- ConditionNumber = 4 => LESS_EQUAL condition .
  8578.          -- FieldNumber = absolute number of the field the package is
  8579.          --               instantiated for .
  8580.          -- AnyAllSwitch = 0 => normal comparison .
  8581.          -- ArraySubscript = 0 => not used as normal comparison .
  8582.  
  8583.       NewCondition := new Condition_Block ;
  8584.       NewCondition.BlockType := Condition ;
  8585.       NewCondition.RHSParameters.ConditionNumber := 4 ;
  8586.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8587.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  8588.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  8589.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8590.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  8591.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8592.            RightHandSideToLongInteger ( RightHandSide ) ;
  8593.  
  8594.       return NewCondition ;
  8595.  
  8596.     end ;
  8597.                    
  8598.  
  8599.  
  8600. -- this function deals with comparison of GREATER_EQUAL betwwen an individual
  8601. -- named array element and a value .
  8602.  
  8603.  
  8604.     function LESS_EQUAL ( Index : integer ;
  8605.                      Value : %5 ) 
  8606.         
  8607.              return  CONDITION_TREE is
  8608.  
  8609.  
  8610.     type RightHandSidePointer is access %5 ;
  8611.  
  8612.     function RightHandSideToLongInteger is new
  8613.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8614.  
  8615.     NewCondition :  CONDITION_TREE ;
  8616.  
  8617.     RightHandSide : RightHandSidePointer ;
  8618.  
  8619.  
  8620.     begin
  8621.  
  8622.       RightHandSide := new %5 ;
  8623.       RightHandSide.all := Value ;
  8624.  
  8625.  
  8626.       -- create a new condition block and set parameter values .
  8627.  
  8628.          -- ConditionNumber = 4 => LESS_EQUAL condition .
  8629.          -- FieldNumber = absolute number of the field the package is
  8630.          --               instantiated for .
  8631.          -- AnyAllSwitch = 1 => named array element comparison.
  8632.          -- ArraySubscript = Index => Compare array element number Index.
  8633.  
  8634.       NewCondition := new Condition_Block ;
  8635.       NewCondition.BlockType := Condition ;
  8636.       NewCondition.RHSParameters.ConditionNumber := 4 ;
  8637.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8638.       NewCondition.RHSParameters.AnyAllSwitch := 1 ;
  8639.       NewCondition.RHSParameters.ArraySubscript := long_integer( index ) ;
  8640.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8641.                    long_integer ( %5'size/NumberOfBitsInAByte ) ;
  8642.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8643.            RightHandSideToLongInteger ( RightHandSide ) ;
  8644.  
  8645.       return NewCondition ;
  8646.  
  8647.     end ;
  8648.                    
  8649.  
  8650.  
  8651.  
  8652.  
  8653.  
  8654. -- this function tests either ALL_ELEMENTS of the array against the value
  8655. -- or to see if ANY_ELEMENT KLESS_EQUAL to the value .
  8656.  
  8657.  
  8658.     function LESS_EQUAL ( Index : GENERAL_ELEMENT ;
  8659.                      Value : %5 ) 
  8660.         
  8661.              return  CONDITION_TREE is
  8662.  
  8663.  
  8664.     type RightHandSidePointer is access %5 ;
  8665.  
  8666.     function RightHandSideToLongInteger is new
  8667.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8668.  
  8669.     NewCondition :  CONDITION_TREE ;
  8670.  
  8671.     RightHandSide : RightHandSidePointer ;
  8672.  
  8673.  
  8674.     begin
  8675.  
  8676.       RightHandSide := new %5 ;
  8677.       RightHandSide.all := Value ;
  8678.  
  8679.  
  8680.       -- create a new condition block and set parameter values .
  8681.  
  8682.          -- ConditionNumber = 4 => LESS_EQUAL condition .
  8683.          -- FieldNumber = absolute number of the field the package is
  8684.          --               instantiated for .
  8685.          -- AnyAllSwitch = -1 or -2 => ANY_ELEMENT or ALL_ELEMENTS .
  8686.          -- ArraySubscript = 0 => not applicable to this condition .
  8687.  
  8688.       NewCondition := new Condition_Block ;
  8689.       NewCondition.BlockType := Condition ;
  8690.       NewCondition.RHSParameters.ConditionNumber := 4 ;
  8691.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8692.  
  8693.       if Index = Any_Element
  8694.          then NewCondition.RHSParameters.AnyAllSwitch := -2 ;
  8695.          else NewCondition.RHSParameters.AnyAllSwitch := -1 ;
  8696.       end if ;
  8697.  
  8698.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  8699.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8700.                    long_integer ( %5'size/NumberOfBitsInAByte ) ; 
  8701.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8702.            RightHandSideToLongInteger ( RightHandSide ) ;
  8703.  
  8704.       return NewCondition ;
  8705.  
  8706.     end ;
  8707.                    
  8708.  
  8709. -------------------------------------------------------------------------------
  8710. --
  8711. -- Function        : To create a condition tree node for the condition 
  8712. --                   LESS_THAN . On string fields comparison is by
  8713. --                   dictionary order .
  8714. --
  8715. -- Input arguments : Value : The value of the RHS of the condition .
  8716. --
  8717. -- Output arguments: Returns a pointer to the created condition tree node .
  8718. --
  8719. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  8720. --
  8721. -- Calls to        : RightHandSideToLongInteger .
  8722. --
  8723. -- Called by       : ADA Application program .
  8724. --
  8725. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  8726. --
  8727. -- Amendments      :                        (  /  /  )
  8728. --
  8729. -- Notes           : 
  8730. --
  8731. -------------------------------------------------------------------------------
  8732.  
  8733.  
  8734. -- this function is testing all of the array elements are LESS_THAN to the
  8735. -- corresponding elemnts of the comparison value .
  8736.  
  8737.  
  8738.     function LESS_THAN ( Value : %2 ) 
  8739.         
  8740.              return  CONDITION_TREE is
  8741.  
  8742.  
  8743.     type RightHandSidePointer is access %2 ;
  8744.  
  8745.     function RightHandSideToLongInteger is new
  8746.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8747.  
  8748.     NewCondition :  CONDITION_TREE ;
  8749.  
  8750.     RightHandSide : RightHandSidePointer ;
  8751.  
  8752.  
  8753.     begin
  8754.  
  8755.       RightHandSide := new %2 ;
  8756.       RightHandSide.all := Value ;
  8757.  
  8758.  
  8759.       -- create a new condition block and set parameter values .
  8760.  
  8761.          -- ConditionNumber = 5 => LESS_THAN condition .
  8762.          -- FieldNumber = absolute number of the field the package is
  8763.          --               instantiated for .
  8764.          -- AnyAllSwitch = 0 => normal comparison .
  8765.          -- ArraySubscript = 0 => not used as normal comparison .
  8766.  
  8767.       NewCondition := new Condition_Block ;
  8768.       NewCondition.BlockType := Condition ;
  8769.       NewCondition.RHSParameters.ConditionNumber := 5 ;
  8770.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8771.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  8772.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  8773.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8774.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  8775.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8776.            RightHandSideToLongInteger ( RightHandSide ) ;
  8777.  
  8778.       return NewCondition ;
  8779.  
  8780.     end ;
  8781.                    
  8782.  
  8783.  
  8784. -- this function deals with comparison of LESS_THAN betwwen an individual
  8785. -- named array element and a value .
  8786.  
  8787.  
  8788.     function LESS_THAN ( Index : integer ;
  8789.                      Value : %5 ) 
  8790.         
  8791.              return  CONDITION_TREE is
  8792.  
  8793.  
  8794.     type RightHandSidePointer is access %5 ;
  8795.  
  8796.     function RightHandSideToLongInteger is new
  8797.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8798.  
  8799.     NewCondition :  CONDITION_TREE ;
  8800.  
  8801.     RightHandSide : RightHandSidePointer ;
  8802.  
  8803.  
  8804.     begin
  8805.  
  8806.       RightHandSide := new %5 ;
  8807.       RightHandSide.all := Value ;
  8808.  
  8809.  
  8810.       -- create a new condition block and set parameter values .
  8811.  
  8812.          -- ConditionNumber = 5 => LESS_THAN condition .
  8813.          -- FieldNumber = absolute number of the field the package is
  8814.          --               instantiated for .
  8815.          -- AnyAllSwitch = 1 => named array element comparison.
  8816.          -- ArraySubscript = Index => Compare array element number Index.
  8817.  
  8818.       NewCondition := new Condition_Block ;
  8819.       NewCondition.BlockType := Condition ;
  8820.       NewCondition.RHSParameters.ConditionNumber := 5 ;
  8821.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8822.       NewCondition.RHSParameters.AnyAllSwitch := 1 ;
  8823.       NewCondition.RHSParameters.ArraySubscript := long_integer( index ) ;
  8824.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8825.                    long_integer ( %5'size/NumberOfBitsInAByte ) ;
  8826.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8827.            RightHandSideToLongInteger ( RightHandSide ) ;
  8828.  
  8829.       return NewCondition ;
  8830.  
  8831.     end ;
  8832.                    
  8833.  
  8834.  
  8835.  
  8836.  
  8837.  
  8838. -- this function tests either ALL_ELEMENTS of the array against the value
  8839. -- or to see if ANY_ELEMENT LESS_THAN to the value .
  8840.  
  8841.  
  8842.     function LESS_THAN ( Index : GENERAL_ELEMENT ;
  8843.                      Value : %5 ) 
  8844.         
  8845.              return  CONDITION_TREE is
  8846.  
  8847.  
  8848.     type RightHandSidePointer is access %5 ;
  8849.  
  8850.     function RightHandSideToLongInteger is new
  8851.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8852.  
  8853.     NewCondition :  CONDITION_TREE ;
  8854.  
  8855.     RightHandSide : RightHandSidePointer ;
  8856.  
  8857.  
  8858.     begin
  8859.  
  8860.       RightHandSide := new %5 ;
  8861.       RightHandSide.all := Value ;
  8862.  
  8863.  
  8864.       -- create a new condition block and set parameter values .
  8865.  
  8866.          -- ConditionNumber = 5 => LESS_THAN condition .
  8867.          -- FieldNumber = absolute number of the field the package is
  8868.          --               instantiated for .
  8869.          -- AnyAllSwitch = -1 or -2 => ANY_ELEMENT or ALL_ELEMENTS .
  8870.          -- ArraySubscript = 0 => not applicable to this condition .
  8871.  
  8872.       NewCondition := new Condition_Block ;
  8873.       NewCondition.BlockType := Condition ;
  8874.       NewCondition.RHSParameters.ConditionNumber := 5 ;
  8875.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8876.  
  8877.       if Index = Any_Element
  8878.          then NewCondition.RHSParameters.AnyAllSwitch := -2 ;
  8879.          else NewCondition.RHSParameters.AnyAllSwitch := -1 ;
  8880.       end if ;
  8881.  
  8882.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  8883.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8884.                    long_integer ( %5'size/NumberOfBitsInAByte ) ; 
  8885.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8886.            RightHandSideToLongInteger ( RightHandSide ) ;
  8887.  
  8888.       return NewCondition ;
  8889.  
  8890.     end ;
  8891.                    
  8892.  
  8893. -------------------------------------------------------------------------------
  8894. --
  8895. -- Function        : To create a condition tree node for the condition 
  8896. --                   UNEQUAL . On string fields comparison is by
  8897. --                   dictionary order .
  8898. --
  8899. -- Input arguments : Value : The value of the RHS of the condition .
  8900. --
  8901. -- Output arguments: Returns a pointer to the created condition tree node .
  8902. --
  8903. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  8904. --
  8905. -- Calls to        : RightHandSideToLongInteger .
  8906. --
  8907. -- Called by       : ADA Application program .
  8908. --
  8909. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  8910. --
  8911. -- Amendments      :                        (  /  /  )
  8912. --
  8913. -- Notes           : 
  8914. --
  8915. -------------------------------------------------------------------------------
  8916.  
  8917.  
  8918. -- this function is testing all of the array elements are UNEQUAL to the
  8919. -- corresponding elemnts of the comparison value .
  8920.  
  8921.  
  8922.     function UNEQUAL ( Value : %2 ) 
  8923.         
  8924.              return  CONDITION_TREE is
  8925.  
  8926.  
  8927.     type RightHandSidePointer is access %2 ;
  8928.  
  8929.     function RightHandSideToLongInteger is new
  8930.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8931.  
  8932.     NewCondition :  CONDITION_TREE ;
  8933.  
  8934.     RightHandSide : RightHandSidePointer ;
  8935.  
  8936.  
  8937.     begin
  8938.  
  8939.       RightHandSide := new %2 ;
  8940.       RightHandSide.all := Value ;
  8941.  
  8942.  
  8943.       -- create a new condition block and set parameter values .
  8944.  
  8945.          -- ConditionNumber = 6 => UNEQUAL condition .
  8946.          -- FieldNumber = absolute number of the field the package is
  8947.          --               instantiated for .
  8948.          -- AnyAllSwitch = 0 => normal comparison .
  8949.          -- ArraySubscript = 0 => not used as normal comparison .
  8950.  
  8951.       NewCondition := new Condition_Block ;
  8952.       NewCondition.BlockType := Condition ;
  8953.       NewCondition.RHSParameters.ConditionNumber := 6 ;
  8954.       NewCondition.RHSParameters.FieldNumber := %3 ;
  8955.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  8956.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  8957.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  8958.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  8959.       NewCondition.RHSParameters.StartOfRightHandSide :=
  8960.            RightHandSideToLongInteger ( RightHandSide ) ;
  8961.  
  8962.       return NewCondition ;
  8963.  
  8964.     end ;
  8965.                    
  8966.  
  8967.  
  8968.  
  8969. -- this function deals with comparison of UNEQUAL betwwen an individual
  8970. -- named array element and a value .
  8971.  
  8972.  
  8973.     function UNEQUAL ( Index : integer ;
  8974.                      Value : %5 ) 
  8975.         
  8976.              return  CONDITION_TREE is
  8977.  
  8978.  
  8979.     type RightHandSidePointer is access %5 ;
  8980.  
  8981.     function RightHandSideToLongInteger is new
  8982.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  8983.  
  8984.     NewCondition :  CONDITION_TREE ;
  8985.  
  8986.     RightHandSide : RightHandSidePointer ;
  8987.  
  8988.  
  8989.     begin
  8990.  
  8991.       RightHandSide := new %5 ;
  8992.       RightHandSide.all := Value ;
  8993.  
  8994.  
  8995.       -- create a new condition block and set parameter values .
  8996.  
  8997.          -- ConditionNumber = 6  => UNEQUAL condition .
  8998.          -- FieldNumber = absolute number of the field the package is
  8999.          --               instantiated for .
  9000.          -- AnyAllSwitch = 1 => named array element comparison.
  9001.          -- ArraySubscript = Index => Compare array element number Index.
  9002.  
  9003.       NewCondition := new Condition_Block ;
  9004.       NewCondition.BlockType := Condition ;
  9005.       NewCondition.RHSParameters.ConditionNumber := 6 ;
  9006.       NewCondition.RHSParameters.FieldNumber := %3 ;
  9007.       NewCondition.RHSParameters.AnyAllSwitch := 1 ;
  9008.       NewCondition.RHSParameters.ArraySubscript := long_integer( index ) ;
  9009.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  9010.                    long_integer ( %5'size/NumberOfBitsInAByte ) ;
  9011.       NewCondition.RHSParameters.StartOfRightHandSide :=
  9012.            RightHandSideToLongInteger ( RightHandSide ) ;
  9013.  
  9014.       return NewCondition ;
  9015.  
  9016.     end ;
  9017.                    
  9018.  
  9019.  
  9020.  
  9021.  
  9022.  
  9023. -- this function tests either ALL_ELEMENTS of the array against the value
  9024. -- or to see if ANY_ELEMENT UNEQUAL to the value .
  9025.  
  9026.  
  9027.     function UNEQUAL ( Index : GENERAL_ELEMENT ;
  9028.                      Value : %5 ) 
  9029.         
  9030.              return  CONDITION_TREE is
  9031.  
  9032.  
  9033.     type RightHandSidePointer is access %5 ;
  9034.  
  9035.     function RightHandSideToLongInteger is new
  9036.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  9037.  
  9038.     NewCondition :  CONDITION_TREE ;
  9039.  
  9040.     RightHandSide : RightHandSidePointer ;
  9041.  
  9042.  
  9043.     begin
  9044.  
  9045.       RightHandSide := new %5 ;
  9046.       RightHandSide.all := Value ;
  9047.  
  9048.  
  9049.       -- create a new condition block and set parameter values .
  9050.  
  9051.          -- ConditionNumber = 6 => UNEQUAL condition .
  9052.          -- FieldNumber = absolute number of the field the package is
  9053.          --               instantiated for .
  9054.          -- AnyAllSwitch = -1 or -2 => ANY_ELEMENT or ALL_ELEMENTS .
  9055.          -- ArraySubscript = 0 => not applicable to this condition .
  9056.  
  9057.       NewCondition := new Condition_Block ;
  9058.       NewCondition.BlockType := Condition ;
  9059.       NewCondition.RHSParameters.ConditionNumber := 6 ;
  9060.       NewCondition.RHSParameters.FieldNumber := %3 ;
  9061.  
  9062.       if Index = Any_Element
  9063.          then NewCondition.RHSParameters.AnyAllSwitch := -2 ;
  9064.          else NewCondition.RHSParameters.AnyAllSwitch := -1 ;
  9065.       end if ;
  9066.  
  9067.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  9068.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  9069.                    long_integer ( %5'size/NumberOfBitsInAByte ) ; 
  9070.       NewCondition.RHSParameters.StartOfRightHandSide :=
  9071.            RightHandSideToLongInteger ( RightHandSide ) ;
  9072.  
  9073.       return NewCondition ;
  9074.  
  9075.     end ;
  9076.  
  9077.  
  9078.  
  9079.  
  9080.                    
  9081.  
  9082.    function UP return ORDERING_TREE is
  9083.  
  9084.  
  9085. -------------------------------------------------------------------------------
  9086. --
  9087. -- Function        : To create an ordering tree leaf node to contain the 
  9088. --                   information that this field is to be in ascending order .
  9089. --
  9090. -- Input arguments : None .
  9091. --
  9092. -- Output arguments: Returns an ordering tree block .
  9093. --
  9094. -- Global variables: PerFile.ORDERING_TREE , PerFile.ORDER_BLOCK
  9095. --
  9096. -- Calls to        : None .
  9097. --
  9098. -- Called by       : ADA Application program .
  9099. --
  9100. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  9101. --
  9102. -- Amendments      :                        (  /  /  )
  9103. --
  9104. -- Notes           : 
  9105. --
  9106. -------------------------------------------------------------------------------
  9107.  
  9108.  
  9109.  
  9110.  
  9111.    TempBlock : ORDERING_TREE ;
  9112.  
  9113.  
  9114.    begin
  9115.  
  9116.      TempBlock := new ORDER_BLOCK ;
  9117.  
  9118.      TempBlock.BlockType := LEAF ;
  9119.      TempBlock.OrderingInformation := %3 ;
  9120.  
  9121.      return TempBlock ;
  9122.  
  9123.    end ;
  9124.  
  9125.  
  9126.  
  9127.  
  9128.  
  9129.  
  9130.  
  9131.    function DOWN return ORDERING_TREE is
  9132.  
  9133.  
  9134.  
  9135. -------------------------------------------------------------------------------
  9136. --
  9137. -- Function        : To create an ordering tree leaf node to contain the 
  9138. --                   information that this field is to be in descending order .
  9139. --
  9140. -- Input arguments : None .
  9141. --
  9142. -- Output arguments: Returns an ordering tree block .
  9143. --
  9144. -- Global variables: PerFile.ORDERING_TREE , PerFile.ORDER_BLOCK
  9145. --
  9146. -- Calls to        : None .
  9147. --
  9148. -- Called by       : ADA Application program .
  9149. --
  9150. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  9151. --
  9152. -- Amendments      :                        (  /  /  )
  9153. --
  9154. -- Notes           : 
  9155. --
  9156. -------------------------------------------------------------------------------
  9157.  
  9158.  
  9159.  
  9160.    TempBlock : ORDERING_TREE ;
  9161.  
  9162.  
  9163.    begin
  9164.  
  9165.      TempBlock := new ORDER_BLOCK ;
  9166.  
  9167.      TempBlock.BlockType := LEAF ;
  9168.      TempBlock.OrderingInformation := -(%3) ;
  9169.  
  9170.      return TempBlock ;
  9171.  
  9172.    end ;
  9173.  
  9174.  
  9175.  
  9176.  
  9177. end ;
  9178.  
  9179. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  9180. --GSCOND.TXT
  9181. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  9182. -----------------------------------------------------------------------
  9183. --                                                                   --
  9184. -- This is a generic package for the conditions on and ordering of   --
  9185. -- a scalar element.                                                 --
  9186. --                                                                   --
  9187. -- The package must be hand instantiated as follows :-               --
  9188. --                                                                   --
  9189. --         Replace   %1  with the name of the package with the       --
  9190. --                       file information .                          --
  9191. --                                                                   --
  9192. --         Replace   %2  with the type of the field declared in      --
  9193. --                       the package specified above.                --
  9194. --                                                                   --
  9195. --         replace   %3  with the number of the absolute number of   --
  9196. --                       the field .                                 --
  9197. --                                                                   --
  9198. --         Replace   %4 with the name of the field specified in      --
  9199. --                       the package containing file information.    --
  9200. --                       This then will become the name of the       --
  9201. --                       package .                                   --
  9202. --                                                                   --
  9203. --         Replace   %5  with the name of the ddf package            --
  9204. --                                                                   --
  9205. --                                                                   --
  9206. --         Finally exit the package as %4.txt and compile it         --
  9207. --                                                                   --
  9208. -----------------------------------------------------------------------
  9209.  
  9210.  
  9211.  
  9212. with %5 , %1 ; use %5 , %1 ;
  9213. with UNCHECKED_CONVERSION , text_io ; use text_io ;
  9214. package %4 is
  9215.  
  9216.  
  9217.     function EQUAL ( Value : %2 ) 
  9218.         
  9219.              return CONDITION_TREE ;
  9220.  
  9221.  
  9222.     function GREATER_EQUAL ( Value : %2 ) 
  9223.         
  9224.              return CONDITION_TREE ;
  9225.  
  9226.  
  9227.     function GREATER_THAN ( Value : %2 ) 
  9228.         
  9229.              return CONDITION_TREE ;
  9230.  
  9231.  
  9232.     function LESS_EQUAL( Value : %2 ) 
  9233.         
  9234.              return CONDITION_TREE ;
  9235.  
  9236.  
  9237.     function LESS_THAN ( Value : %2 ) 
  9238.         
  9239.              return CONDITION_TREE ;
  9240.  
  9241.  
  9242.     function UNEQUAL ( Value : %2 ) 
  9243.         
  9244.              return CONDITION_TREE ;
  9245.  
  9246.  
  9247.  
  9248.  
  9249.  
  9250.     function UP return ORDERING_TREE ;
  9251.  
  9252.  
  9253.     function DOWN return ORDERING_TREE ;
  9254.  
  9255.  
  9256. end ;
  9257.  
  9258.  
  9259.  
  9260.  
  9261.  
  9262.  
  9263.  
  9264. package body %4 is
  9265.  
  9266.  
  9267.  
  9268. NumberOfBitsInAByte : constant integer := 8 ;
  9269.  
  9270.  
  9271. -------------------------------------------------------------------------
  9272. -------------------------------------------------------------------------
  9273. --                                                                     --
  9274. --             NOTE ON THE IMPLEMENTATION OF CONDITIONS                --
  9275. --                                                                     --
  9276. --     All of the conditions take the same form .                      --
  9277. --                                                                     --
  9278. --              * A pointer to the type of the field is set up .       --
  9279. --              * It is instantiated and set equal to the RHS of       --
  9280. --                the condition .                                      --
  9281. --              * The address of the pointer is calculated by a        --
  9282. --                function translating from a pointer type to a long   --
  9283. --                integer type .                                       --
  9284. --              * The size of the RHS is the size of the field_type    --
  9285. --              * The start and size of the RHS along with the         --
  9286. --                condition number are stored in the condition tree    --
  9287. --                                                                     --
  9288. --     A pointer type was used to store the value of the RHS of a      --
  9289. -- condition as is the only type that can be used . A local variable   --
  9290. -- (to the function) would dissapear after termination of the function --
  9291. -- Pointers live on . A global variable would be unsuitable as it is   --
  9292. -- not known at compile time the amount of conditions that are to be   --
  9293. -- set . Pointers are dynamic and so this problem does not arise .     --
  9294. --                                                                     --
  9295. -------------------------------------------------------------------------
  9296. -------------------------------------------------------------------------
  9297.  
  9298.  
  9299.  
  9300.     function EQUAL ( Value : %2 ) 
  9301.         
  9302.              return CONDITION_TREE is
  9303.  
  9304. -------------------------------------------------------------------------------
  9305. --
  9306. -- Function        : To craete a condition tree node for the condition EQUAL .
  9307. --                   Note equlaity applied to string fields is true if every
  9308. --                   element of the strings being compared is identical .
  9309. --
  9310. -- Input arguments : Value : The value of the RHS of the condition .
  9311. --
  9312. -- Output arguments: Returns a pointer to the created condition tree node .
  9313. --
  9314. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  9315. --
  9316. -- Calls to        : RightHandSideToLongInteger .
  9317. --
  9318. -- Called by       : ADA Application program .
  9319. --
  9320. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  9321. --
  9322. -- Amendments      :                        (  /  /  )
  9323. --
  9324. -- Notes           : 
  9325. --
  9326. -------------------------------------------------------------------------------
  9327.  
  9328.  
  9329.  
  9330.  
  9331.     type RightHandSidePointer is access %2 ;
  9332.  
  9333.     function RightHandSideToLongInteger is new
  9334.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  9335.  
  9336.     NewCondition : CONDITION_TREE ;
  9337.  
  9338.     RightHandSide : RightHandSidePointer ;
  9339.  
  9340.  
  9341.     begin
  9342.  
  9343.  
  9344.       -- instantiate the pointer to the type of the right hand side
  9345.       -- and set it equal to the comparison value .
  9346.  
  9347.       RightHandSide := new %2 ;
  9348.       RightHandSide.all := Value ;
  9349.  
  9350.  
  9351.       -- create a new condition block and set parameter values .
  9352.  
  9353.          -- ConditionNumber = 1 => EQUAL condition .
  9354.          -- FieldNumber = absolute number of the field the package is
  9355.          --               instantiated for .
  9356.          -- AnyAllSwitch = 0 => normal comparison .
  9357.          -- ArraySubscript = 0 => not dealing with arrays .
  9358.          
  9359.  
  9360.       NewCondition := new Condition_Block ;
  9361.       NewCondition.BlockType := Condition ;
  9362.       NewCondition.RHSParameters.ConditionNumber := 1 ;
  9363.       NewCondition.RHSParameters.FieldNumber := %3 ;
  9364.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  9365.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  9366.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  9367.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  9368.       NewCondition.RHSParameters.StartOfRightHandSide :=
  9369.            RightHandSideToLongInteger ( RightHandSide ) ;
  9370.  
  9371.  
  9372.       return NewCondition ;
  9373.  
  9374.     end ;
  9375.  
  9376.  
  9377.  
  9378.  
  9379.  
  9380.     function GREATER_EQUAL ( Value : %2 ) 
  9381.         
  9382.              return CONDITION_TREE is
  9383.  
  9384.  
  9385. -------------------------------------------------------------------------------
  9386. --
  9387. -- Function        : To create a condition tree node for the condition 
  9388. --                   GREATER_EQUAL . Note GREATER_EQUAL applied to string 
  9389. --                   fields is based on dictionary order .
  9390. --
  9391. -- Input arguments : Value : The value of the RHS of the condition .
  9392. --
  9393. -- Output arguments: Returns a pointer to the created condition tree node .
  9394. --
  9395. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  9396. --
  9397. -- Calls to        : RightHandSideToLongInteger .
  9398. --
  9399. -- Called by       : ADA Application program .
  9400. --
  9401. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  9402. --
  9403. -- Amendments      :                        (  /  /  )
  9404. --
  9405. -- Notes           : 
  9406. --
  9407. -------------------------------------------------------------------------------
  9408.  
  9409.  
  9410.     type RightHandSidePointer is access %2 ;
  9411.  
  9412.     function RightHandSideToLongInteger is new
  9413.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  9414.  
  9415.     NewCondition : CONDITION_TREE ;
  9416.  
  9417.     RightHandSide : RightHandSidePointer ;
  9418.  
  9419.  
  9420.     begin
  9421.  
  9422.  
  9423.       -- instantiate the pointer to the type of the right hand side
  9424.       -- and set it equal to the comparison value .
  9425.  
  9426.       RightHandSide := new %2 ;
  9427.       RightHandSide.all := Value ;
  9428.  
  9429.  
  9430.       -- create a new condition block and set parameter values .
  9431.  
  9432.          -- ConditionNumber = 2 => GREATER_EQUAL condition .
  9433.          -- FieldNumber = absolute number of the field the package is
  9434.          --               instantiated for .
  9435.          -- AnyAllSwitch = 0 => normal comparison .
  9436.          -- ArraySubscript = 0 => not dealing with arrays .
  9437.  
  9438.  
  9439.       NewCondition := new Condition_Block ;
  9440.       NewCondition.BlockType := Condition ;
  9441.       NewCondition.RHSParameters.ConditionNumber := 2 ;
  9442.       NewCondition.RHSParameters.FieldNumber := %3 ;
  9443.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  9444.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  9445.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  9446.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  9447.       NewCondition.RHSParameters.StartOfRightHandSide :=
  9448.            RightHandSideToLongInteger ( RightHandSide ) ;
  9449.  
  9450.  
  9451.       return NewCondition ;
  9452.  
  9453.     end ;
  9454.  
  9455.  
  9456.  
  9457.  
  9458.  
  9459.     function GREATER_THAN ( Value : %2 ) 
  9460.         
  9461.              return CONDITION_TREE is
  9462.  
  9463.  
  9464. -------------------------------------------------------------------------------
  9465. --
  9466. -- Function        : To craete a condition tree node for the condition 
  9467. --                   GREATER_THAN . Note GREATER_THAN applied to string 
  9468. --                   fields is based on dictionary order .
  9469. --
  9470. -- Input arguments : Value : The value of the RHS of the condition .
  9471. --
  9472. -- Output arguments: Returns a pointer to the created condition tree node .
  9473. --
  9474. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  9475. --
  9476. -- Calls to        : RightHandSideToLongInteger .
  9477. --
  9478. -- Called by       : ADA Application program .
  9479. --
  9480. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  9481. --
  9482. -- Amendments      :                        (  /  /  )
  9483. --
  9484. -- Notes           : 
  9485. --
  9486. -------------------------------------------------------------------------------
  9487.  
  9488.  
  9489.     type RightHandSidePointer is access %2 ;
  9490.  
  9491.     function RightHandSideToLongInteger is new
  9492.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  9493.  
  9494.     NewCondition : CONDITION_TREE ;
  9495.  
  9496.     RightHandSide : RightHandSidePointer ;
  9497.  
  9498.  
  9499.     begin
  9500.  
  9501.  
  9502.       -- instantiate the pointer to the type of the right hand side
  9503.       -- and set it equal to the comparison value .
  9504.  
  9505.       RightHandSide := new %2 ;
  9506.       RightHandSide.all := Value ;
  9507.  
  9508.  
  9509.       -- create a new condition block and set parameter values .
  9510.  
  9511.          -- ConditionNumber = 3 => GREATER_THAN condition .
  9512.          -- FieldNumber = absolute number of the field the package is
  9513.          --               instantiated for .
  9514.          -- AnyAllSwitch = 0 => normal comparison .
  9515.          -- ArraySubscript = 0 => not dealing with arrays .
  9516.  
  9517.  
  9518.       NewCondition := new Condition_Block ;
  9519.       NewCondition.BlockType := Condition ;
  9520.       NewCondition.RHSParameters.ConditionNumber := 3 ;
  9521.       NewCondition.RHSParameters.FieldNumber := %3 ;
  9522.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  9523.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  9524.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  9525.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  9526.       NewCondition.RHSParameters.StartOfRightHandSide :=
  9527.            RightHandSideToLongInteger ( RightHandSide ) ;
  9528.  
  9529.  
  9530.       return NewCondition ;
  9531.  
  9532.     end ;
  9533.  
  9534.  
  9535.  
  9536.  
  9537.  
  9538.     function LESS_EQUAL ( Value : %2 ) 
  9539.         
  9540.              return CONDITION_TREE is
  9541.  
  9542.  
  9543.  
  9544. -------------------------------------------------------------------------------
  9545. --
  9546. -- Function        : To create a condition tree node for the condition 
  9547. --                   LESS_EQUAL . Note LESS_EQUAL applied to string fields is 
  9548. --                   based on dictionary order .
  9549. --
  9550. -- Input arguments : Value : The value of the RHS of the condition .
  9551. --
  9552. -- Output arguments: Returns a pointer to the created condition tree node .
  9553. --
  9554. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  9555. --
  9556. -- Calls to        : RightHandSideToLongInteger .
  9557. --
  9558. -- Called by       : ADA Application program .
  9559. --
  9560. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  9561. --
  9562. -- Amendments      :                        (  /  /  )
  9563. --
  9564. -- Notes           : 
  9565. --
  9566. -------------------------------------------------------------------------------
  9567.  
  9568.     type RightHandSidePointer is access %2 ;
  9569.  
  9570.     function RightHandSideToLongInteger is new
  9571.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  9572.  
  9573.     NewCondition : CONDITION_TREE ;
  9574.  
  9575.     RightHandSide : RightHandSidePointer ;
  9576.  
  9577.  
  9578.     begin
  9579.  
  9580.       -- instantiate the pointer to the type of the right hand side
  9581.       -- and set it equal to the comparison value .
  9582.  
  9583.       RightHandSide := new %2 ;
  9584.       RightHandSide.all := Value ;
  9585.  
  9586.  
  9587.       -- create a new condition block and set parameter values .
  9588.  
  9589.          -- ConditionNumber = 4 => LESS_EQUAL condition .
  9590.          -- FieldNumber = absolute number of the field the package is
  9591.          --               instantiated for .
  9592.          -- AnyAllSwitch = 0 => normal comparison .
  9593.          -- ArraySubscript = 0 => not dealing with arrays .
  9594.  
  9595.  
  9596.       NewCondition := new Condition_Block ;
  9597.       NewCondition.BlockType := Condition ;
  9598.       NewCondition.RHSParameters.ConditionNumber := 4 ;
  9599.       NewCondition.RHSParameters.FieldNumber := %3 ;
  9600.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  9601.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  9602.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  9603.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  9604.       NewCondition.RHSParameters.StartOfRightHandSide :=
  9605.            RightHandSideToLongInteger ( RightHandSide ) ;
  9606.  
  9607.       
  9608.       return NewCondition ;
  9609.  
  9610.     end ;
  9611.  
  9612.  
  9613.  
  9614.  
  9615.  
  9616.     function LESS_THAN ( Value : %2 ) 
  9617.         
  9618.              return CONDITION_TREE is
  9619.  
  9620.  
  9621. -------------------------------------------------------------------------------
  9622. --
  9623. -- Function        : To create a condition tree node for the condition 
  9624. --                   LESS_THAN .Note LESS_THAN applied to string fields is 
  9625. --                   based on all strings before in dictionary order .
  9626. --
  9627. -- Input arguments : Value : The value of the RHS of the condition .
  9628. --
  9629. -- Output arguments: Returns a pointer to the created condition tree node .
  9630. --
  9631. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  9632. --
  9633. -- Calls to        : RightHandSideToLongInteger .
  9634. --
  9635. -- Called by       : ADA Application program .
  9636. --
  9637. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  9638. --
  9639. -- Amendments      :                        (  /  /  )
  9640. --
  9641. -- Notes           : 
  9642. --
  9643. -------------------------------------------------------------------------------
  9644.  
  9645.  
  9646.     type RightHandSidePointer is access %2 ;
  9647.  
  9648.     function RightHandSideToLongInteger is new
  9649.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  9650.  
  9651.     NewCondition : CONDITION_TREE ;
  9652.  
  9653.     RightHandSide : RightHandSidePointer ;
  9654.  
  9655.  
  9656.     begin
  9657.  
  9658.  
  9659.       -- instantiate the pointer to the type of the right hand side
  9660.       -- and set it equal to the comparison value .
  9661.  
  9662.       RightHandSide := new %2 ;
  9663.       RightHandSide.all := Value ;
  9664.  
  9665.  
  9666.       -- create a new condition block and set parameter values .
  9667.  
  9668.          -- ConditionNumber = 5 => LESS_THAN condition .
  9669.          -- FieldNumber = absolute number of the field the package is
  9670.          --               instantiated for .
  9671.          -- AnyAllSwitch = 0 => normal comparison .
  9672.          -- ArraySubscript = 0 => not dealing with arrays .
  9673.  
  9674.  
  9675.       NewCondition := new Condition_Block ;
  9676.       NewCondition.BlockType := Condition ;
  9677.       NewCondition.RHSParameters.ConditionNumber := 5 ;
  9678.       NewCondition.RHSParameters.FieldNumber := %3 ;
  9679.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  9680.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  9681.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  9682.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  9683.       NewCondition.RHSParameters.StartOfRightHandSide :=
  9684.            RightHandSideToLongInteger ( RightHandSide ) ;
  9685.  
  9686.  
  9687.       return NewCondition ;
  9688.  
  9689.     end ;
  9690.  
  9691.  
  9692.  
  9693.  
  9694.  
  9695.     function UNEQUAL( Value : %2 ) 
  9696.         
  9697.              return CONDITION_TREE is
  9698.  
  9699.  
  9700.  
  9701. -------------------------------------------------------------------------------
  9702. --
  9703. -- Function        : To create a condition tree node for the condition 
  9704. --                   UNEQUAL .Note inequlaity applied to string fields is true 
  9705. --                   if any element of the strings being compared is 
  9706. --                   different .
  9707. --
  9708. -- Input arguments : Value : The value of the RHS of the condition .
  9709. --
  9710. -- Output arguments: Returns a pointer to the created condition tree node .
  9711. --
  9712. -- Global variables: PerFile.CONDITION_TREE , PerFile.CONDITION_BLOCK .
  9713. --
  9714. -- Calls to        : RightHandSideToLongInteger .
  9715. --
  9716. -- Called by       : ADA Application program .
  9717. --
  9718. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  9719. --
  9720. -- Amendments      :                        (  /  /  )
  9721. --
  9722. -- Notes           : 
  9723. --
  9724. -------------------------------------------------------------------------------
  9725.  
  9726.  
  9727.     type RightHandSidePointer is access %2 ;
  9728.  
  9729.     function RightHandSideToLongInteger is new
  9730.              UNCHECKED_CONVERSION ( RightHandSidePointer , long_integer ) ;
  9731.  
  9732.     NewCondition : CONDITION_TREE ;
  9733.  
  9734.     RightHandSide : RightHandSidePointer ;
  9735.  
  9736.  
  9737.     begin
  9738.  
  9739.  
  9740.       -- instantiate the pointer to the type of the right hand side
  9741.       -- and set it equal to the comparison value .
  9742.  
  9743.       RightHandSide := new %2 ;
  9744.       RightHandSide.all := Value ;
  9745.  
  9746.  
  9747.       -- create a new condition block and set parameter values .
  9748.  
  9749.          -- ConditionNumber = 6 => UNEQUAL condition .
  9750.          -- FieldNumber = absolute number of the field the package is
  9751.          --               instantiated for .
  9752.          -- AnyAllSwitch = 0 => normal comparison .
  9753.          -- ArraySubscript = 0 => not dealing with arrays .
  9754.  
  9755.  
  9756.       NewCondition := new Condition_Block ;
  9757.       NewCondition.BlockType := Condition ;
  9758.       NewCondition.RHSParameters.ConditionNumber := 6 ;
  9759.       NewCondition.RHSParameters.FieldNumber := %3 ;
  9760.       NewCondition.RHSParameters.AnyAllSwitch := 0 ;
  9761.       NewCondition.RHSParameters.ArraySubscript := 0 ;
  9762.       NewCondition.RHSParameters.SizeOfRightHandSide := 
  9763.                                  long_integer ( %2'size/NumberOfBitsInAByte ) ;
  9764.       NewCondition.RHSParameters.StartOfRightHandSide :=
  9765.            RightHandSideToLongInteger ( RightHandSide ) ;
  9766.  
  9767.  
  9768.       return NewCondition ;
  9769.  
  9770.     end ;
  9771.                    
  9772.  
  9773.  
  9774.  
  9775. function UP return ORDERING_TREE is 
  9776.  
  9777.  
  9778. -------------------------------------------------------------------------------
  9779. --
  9780. -- Function        : To create an ordering tree leaf node to contain the 
  9781. --                   information that this field is to be in ascending order .
  9782. --
  9783. -- Input arguments : None .
  9784. --
  9785. -- Output arguments: Returns an ordering tree block .
  9786. --
  9787. -- Global variables: PerFile.ORDERING_TREE , PerFile.ORDER_BLOCK
  9788. --
  9789. -- Calls to        : None .
  9790. --
  9791. -- Called by       : ADA Application program .
  9792. --
  9793. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  9794. --
  9795. -- Amendments      :                        (  /  /  )
  9796. --
  9797. -- Notes           : 
  9798. --
  9799. -------------------------------------------------------------------------------
  9800.  
  9801.  
  9802. TempBlock : ORDERING_TREE ;
  9803.  
  9804. begin
  9805.  
  9806.   TempBlock := new Order_Block ;
  9807.  
  9808.   -- we are creating a leaf node ( bottom of the ordering tree )
  9809.  
  9810.   TempBlock.BlockType := LEAF ;
  9811.  
  9812.   -- the fact that field x is to be in ascending order is specified by storing
  9813.   -- the number + x
  9814.  
  9815.   TempBlock.OrderingInformation := %3 ;
  9816.  
  9817.   return TempBlock ;
  9818.  
  9819. end ;
  9820.  
  9821.  
  9822.  
  9823.  
  9824. function DOWN return ORDERING_TREE is 
  9825.  
  9826. -------------------------------------------------------------------------------
  9827. --
  9828. -- Function        : To create an ordering tree leaf node to contain the 
  9829. --                   information that this field is to be in descending order .
  9830. --
  9831. -- Input arguments : None .
  9832. --
  9833. -- Output arguments: Returns an ordering tree block .
  9834. --
  9835. -- Global variables: PerFile.ORDERING_TREE , PerFile.ORDER_BLOCK
  9836. --
  9837. -- Calls to        : None .
  9838. --
  9839. -- Called by       : ADA Application program .
  9840. --
  9841. -- Author          : RP/MDD                 (  /  /  )     Version 1.0
  9842. --
  9843. -- Amendments      :                        (  /  /  )
  9844. --
  9845. -- Notes           : 
  9846. --
  9847. -------------------------------------------------------------------------------
  9848.  
  9849.  
  9850. TempBlock : ORDERING_TREE ;
  9851.  
  9852. begin
  9853.  
  9854.   TempBlock := new Order_Block ;
  9855.  
  9856.   -- we are creating a LEAF node ( at the bottom of the tree )
  9857.  
  9858.   TempBlock.BlockType :=  LEAF ;
  9859.  
  9860.   -- the fact that field x is to be in ascending order is stored as - x
  9861.  
  9862.   TempBlock.OrderingInformation := -(%3) ;
  9863.  
  9864.   return TempBlock ;
  9865.  
  9866. end ;
  9867.  
  9868.  
  9869.  
  9870.  
  9871. end ;
  9872.  
  9873. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  9874. --ADARAP.COM
  9875. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  9876. $! First define the name of the "TeleSoft Code" directory
  9877. $! ****************************
  9878. $DEFINE TADA$DIR DBA2:[ADARAPP.ADK]
  9879. $! ****************************
  9880. $! Now define all the relevant code files
  9881. $ DEFINE TADA$RTK    TADA$DIR:V30R23
  9882. $ DEFINE TADA$PSE    TADA$DIR:ROS.ROS
  9883. $ DEFINE TADA$ACOMP  TADA$DIR:CMDADA.COD
  9884. $ DEFINE TADA$PCOMP  TADA$DIR:PASCAL.COD
  9885. $ DEFINE TADA$TRVAX  TADA$DIR:TRVAX.COD
  9886. $ DEFINE TADA$EDIT   "EDIT/EDT"
  9887. $!
  9888. $! Enable the Help library
  9889. $ DEFINE HLP$LIBRARY_1 TADA$DIR:TELESOFT
  9890. $!
  9891. $! Set up the default file types
  9892. $!     DEFINE TADA$IPT    ".ADA"
  9893. $!     DEFINE TADA$OPT    ".ROS"
  9894. $!
  9895. $! ******************************************
  9896. $ DEFINE HLP$LIBRARY_2 DBA2:[ADARAPP.HELP]ADK.HLB
  9897. $! ******************************************
  9898. $!
  9899. $! This file sets up all the commands and assignments required
  9900. $! by a user for RAPPORT-4
  9901. $!
  9902. $! ************************************************
  9903. $assign DBA2:[RAPPVMS3] rapport4:
  9904. $assign __DBA2:[RAPPVMS3.] rapproot4:
  9905. $assign DBA2:[RAPPVMS3] rapport2:
  9906. $assign __DBA2:[RAPPVMS3.] rapproot2:
  9907. $assign DBA2:[adaRAPP] adarap:
  9908. $assign __DBA2:[adaRAPP.] araproot:
  9909. $ ASSIGN araproot:[fortran]USERCALL.EXE ADA$SUBNUC
  9910. $set command/tables=adarap:r4user.exe
  9911. $! ************************************************
  9912. $define hlp$library rapport4:rapport4.hlb
  9913. $rapie*r   :== zzzz
  9914. $err*or    :== "@rapport4:errorlist.com"
  9915. $t*ype     :== type
  9916. $lo*gout   :== logout
  9917. !
  9918. ! OPTIONS --- Set Global Logical names stating which
  9919. !             RAPPORT-4 options are installed and which
  9920. !             older RAPPORT versions were installed.
  9921. !
  9922. $!
  9923. $! Set up flags to be used throughout the RAPPORT-4 tests and
  9924. $! maintainence command files.
  9925. $!
  9926. $   TRUE      == 1 .eq. 1
  9927. $   FALSE     == 1 .eq. 0
  9928. $!
  9929. $! DCL Global variable     Installed ? Description
  9930. $!
  9931. $  opt_nucleus_backup==     TRUE      ! Nucleus with Backup and Recovery
  9932. $  opt_data_security ==     TRUE      ! Data security
  9933. $  opt_multi_user    ==     TRUE      ! Multi-user
  9934. $  opt_rapide        ==     TRUE      ! RAPIDE
  9935. $  opt_rapide_de     ==     FALSE     ! Rapide Data-Entry
  9936. $  opt_rapier        ==     TRUE      ! Rapier
  9937. $  opt_fortran_66    ==     FALSE     ! (Option Unavailable)
  9938. $  opt_fortran_77    ==     TRUE      ! FORTRAN-77 interface
  9939. $  opt_COBOL         ==     FALSE     ! COBOL interface
  9940. $  opt_pascal        ==     TRUE      ! PASCAL interface
  9941. $!
  9942. $! determine which , if any, old RAPPORT versions exist at this site
  9943. $!
  9944. $  opt_rapport_1_02  ==     FALSE     ! determines need for CSVAMP
  9945. $  opt_rapport_3     ==     FALSE     ! determines need for C4VAMP
  9946. $!
  9947. $ RLINK :== @adarap:MUFORAPPL.COM
  9948. $ RSLINK :== @adarap:SUFORAPPL.COM
  9949. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  9950. --LOGIN.COM
  9951. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  9952. $ SET NOVERIFY
  9953. $ ON CONTROL_Y THEN CONTINUE
  9954. $ SET DEF DBA2:[ADARAPP]
  9955. $ SET PROT/PROT=(O:RWED,S:RWE,G:R)/DEFAULT
  9956. $ @adarap.com
  9957. $ defs :== @[adarapp.distoct84.adk]tadadefs
  9958. $ ADK :== SET DEFAULT dba2:[adarapp.ADK]
  9959. $ HOME :== SET DEFAULT dba2:[adarapp.ada]
  9960. $ UNI :== SET DEF DBA2:[ADARAPP.UNITREP]
  9961. $ STARTNUC :== SUBMIT/NOPRINTER/LOG=dba2:[adarapp]NUCLEUS.LOG DBA2:[ADARAPP]NUCRUN.COM
  9962. $ STOPNUC :== SERVICE/NAME=ADANUC
  9963. $ STARTUNIT :== SUBMIT/NOPRINT [ADARAPP.UNITREP]NUCRUN
  9964. $ STOPUNIT :== SERVICE/NAME=UNITNUC
  9965. $ UP :== SET DEFAULT [-]
  9966. $ SBQ :== SHOW QUEUE SYS$BATCH/ALL
  9967. $ SPQ :== SHOW QUEUE TXA6/ALL
  9968. $ PRI :== PRINT/QUEUE=TXA6/NOFLAG
  9969. $ DD :== DIR *.DIR
  9970. $ TODRA0 :== @DBA2:[ADARAPP]TODRA0.COM
  9971. $ USER1 :== SET DEFAULT DBA2:[ADARAPP.COURSE.USER1]
  9972. $ USER2 :== SET DEFAULT DBA2:[ADARAPP.COURSE.USER2]
  9973. $ USER3 :== SET DEFAULT DBA2:[ADARAPP.COURSE.USER3]
  9974. $ USER4 :== SET DEFAULT DBA2:[ADARAPP.COURSE.USER4]
  9975. $ USER5 :== SET DEFAULT DBA2:[ADARAPP.COURSE.USER5]
  9976. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  9977. --MUFORAPPL.COM
  9978. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  9979. !
  9980. ! MUFORAPPL --- This is the build file for a multi-user Fortran
  9981. !               application program.
  9982. !
  9983. $link/trace/exe='P1.exe -
  9984.                  'P1, -
  9985.                  rapproot4:[objs]umblok, -
  9986.                                  mduslbblk, -
  9987.                  rapproot4:[libs]userlb/lib, -
  9988.                                  nuinlb/lib, -
  9989.                                  nodslb/lib, -
  9990.                                  mpinlb/lib, -
  9991.                                  poollb/lib,mduslb/lib,corelb/lib
  9992. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  9993. --NUCRUN.COM
  9994. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  9995. NUCLEUS
  9996. ADANUC
  9997. araproot:[unitrep]unitrep
  9998. ENTER
  9999. CONT
  10000. EXIT
  10001. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  10002. --R4USER.COM
  10003. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  10004. $!
  10005. $! This file sets up all the commands and assignments required
  10006. $! by a user for RAPPORT-4
  10007. $!
  10008. $assign DRA1:[RAPPORT4] rapport4:
  10009. $assign __DRA1:[RAPPORT4.] rapproot4:
  10010. $assign DRA1:[RAPPORT4] rapport2:
  10011. $assign __DRA1:[RAPPORT4.] rapproot2:
  10012. $set command/tables=rapport4:r4user.exe
  10013. $define hlp$library rapport4:rapport4.hlb
  10014. $rapie*r   :== zzzz
  10015. $err*or    :== "@rapport4:errorlist.com"
  10016. $t*ype     :== type
  10017. $lo*gout   :== logout
  10018. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  10019. --R4USERCLD.COM
  10020. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  10021. $copy sys$library:dcltables.exe r4user.exe
  10022. $set command/output=r4user.exe -
  10023.             /tables=r4user.exe -
  10024.                     r4user.cld
  10025. $set command/tables=r4user.exe
  10026. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  10027. --REFRESH.COM
  10028. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  10029. copy rapproot4:[companies.fortran]'P1.dbs -
  10030.      araproot:[companies]'P1.dbs
  10031. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  10032. --SUFORAPPL.COM
  10033. --::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  10034. !
  10035. ! SUFORAPPL --- This is the build file for a single-user Fortran
  10036. !               application program. 
  10037. !
  10038. $link/trace/exe='P1.exe -
  10039.                 'P1.OBJ, -
  10040.                 rapproot4:[objs]usblok, -
  10041.                                 mduslbblk, -
  10042.                 rapproot4:[libs]userlb/lib, -
  10043.                                 nucolb/lib, -
  10044.                                 lonulb/lib, -
  10045.                                 singlb/lib, -
  10046.                                 nodslb/lib, -
  10047.                                 poollb/lib,mduslb/lib,corelb/lib
  10048.  
  10049.