Trailing-Edge
-
PDP-10 Archives
-
BB-4148E-BM
-
sources/thefoi.fml
There are 2 other files named thefoi.fml in the archive. Click here to see a list.
PROGRAM INIT
IMPLICIT INTEGER (A-Z)
LOGICAL INVKEY, ENDSET, SIMDEL, OK, EXMS, DONE
COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
COMMON /EX/ EXMS
COMMON /UTIL/ FUNCTN
C *******************************************************************
C * *
C * copyright (c) 1980 DIGITAL Equipment Corporation *
C * *
C * This program is for instructional purposes only; in order to *
C * illustrate certain aspects of this software, this program may *
C * contain constructs and practices that would not be suitable *
C * for use in a production environment. DIGITAL Equipment Cor- *
C * poration assumes no responsibility for any errors which may *
C * exist in this program. *
C * *
C * This program was written by software documentation staff in *
C * order to best explain concepts involved in using the DBMS DML. *
C * As such, the primary consideration was writing code that is, *
C * for the most part, as simple as possible. Consequently, the *
C * approach taken was to write in-line code because, for the most *
C * part, it can be easier to understand, albeit harder to main- *
C * tain. *
C * *
C * A second major factor in the writing of this program was that *
C * only one program could be written. This constraint was added *
C * because the theme example programs are included on the dis- *
C * tribution tape and we could only include one program there. *
C * Consequently, the procedure shown here where everything is in- *
C * cluded in one program is not one that should be followed by *
C * users performing similiar kinds of functions. *
C * *
C * Also, this program was written solely to demonstrate a dis- *
C * series of functions. While all these functions work, they *
C * were not given the kind of load and performance testing that *
C * should be, or are, given to true application software. *
C * *
C *******************************************************************
*DBMS
INVOKE SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
PRIVACY KEY FOR COMPILE IS ACEDB.
*DBMS
USE ERRTN IF ERSTAT.
EXMS = .TRUE.
*DBMS
OPEN AREA Head-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF (ERSTAT .EQ. 0) GO TO 1
TYPE 2
2 FORMAT (' Not able to open Head-Area.')
GO TO 999
1 CONTINUE
*DBMS
OPEN AREA Index-Block-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF (ERSTAT .EQ. 0) GO TO 3
TYPE 4
4 FORMAT (' Not able to open Index-Block-area.')
GO TO 999
3 CONTINUE
*DBMS
OPEN AREA Inventory-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF (ERSTAT .EQ. 0) GO TO 5
TYPE 6
6 FORMAT (' Not able to open Inventory-Area.')
GO TO 999
5 CONTINUE
*DBMS
OPEN AREA Manufacturing-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF (ERSTAT .EQ. 0) GO TO 7
TYPE 8
8 FORMAT (' Not able to open Manufacturing-Area.')
GO TO 999
7 CONTINUE
*DBMS
OPEN AREA Orders-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF (ERSTAT .EQ. 0) GO TO 9
TYPE 88
88 FORMAT (' Not able to open Orders-Area.')
GO TO 999
9 CONTINUE
*DBMS
OPEN AREA Personnel-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF (ERSTAT .EQ. 0) GO TO 10
TYPE 11
11 FORMAT (' Not able to open Personnel-Area.')
GO TO 999
10 CONTINUE
*DBMS
OPEN AREA Personal-Area
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF (ERSTAT .EQ. 0) GO TO 21
TYPE 22
22 FORMAT (' Not able to open Personal-Area')
GO TO 999
21 CONTINUE
*DBMS
OPEN AREA TEMPORARY-AREA
USAGE-MODE IS EXCLUSIVE UPDATE
PRIVACY KEY IS N1234.
IF (ERSTAT .EQ. 0) GO TO 24
TYPE 23
23 FORMAT ('NOT ABLE TO OPEN TEMPORARY-AREA')
GO TO 999
C* Initialize. *
24 CONTINUE
OHDUM = -1
OHNUM = 0
*DBMS
STORE Number-of-Last-Order-Rec.
IF (ERSTAT .EQ. 0) GO TO 200
TYPE 100
100 FORMAT (' Number of last order record not stored')
GO TO 999
200 TYPE 210
210 FORMAT (' NUMBER-OF-LAST-ORDER-REC STORED')
CHDUM = -1
CHNUM = 0
*DBMS
STORE Cust-Head-Rec.
IF (ERSTAT .EQ. 0) GO TO 400
TYPE 300
300 FORMAT (' Cust-Head not stored.')
GO TO 999
400 TYPE 500
500 FORMAT (' Cust-head stored.')
EHDUM = -1
EHNUM = 0
*DBMS
STORE Employee-Head-Rec.
IF (ERSTAT .EQ. 0) GO TO 700
TYPE 600
600 FORMAT (' Employee-Head not stored.')
GO TO 999
700 TYPE 800
800 FORMAT (' Employee-Head stored.')
PRDUM = -1
PRNUM = 0
*DBMS
STORE Part-Head-Rec.
IF (ERSTAT .EQ. 0) GO TO 1000
TYPE 900
900 FORMAT (' Part-Head not stored')
GO TO 999
1000 TYPE 1100
1100 FORMAT (' Part-Head stored.')
PHDUM = -1
PHNUM = 0
*DBMS
STORE Purchase-Order-Head-Rec.
IF (ERSTAT .EQ. 0) GO TO 1300
TYPE 1200
1200 FORMAT (' Purchase-Order-Head not stored.')
GO TO 999
1300 TYPE 1310
1310 FORMAT (' PURCHASE-ORDER-HEAD-REC STORED')
WHDUM = -1
WHNUM = 0
*DBMS
STORE Work-Order-Head-Rec.
IF (ERSTAT .EQ. 0) GO TO 1500
TYPE 1400
1400 FORMAT (' Work-Order-Head not stored')
GO TO 999
1500 TYPE 1600
1600 FORMAT (' Work-Order-Head stored.')
999 CONTINUE
*DBMS
CLOSE RUN-UNIT.
*DBMS
CLOSE JOURNAL.
*DBMS
END INIT.
SUBROUTINE ERRTN
C*******************************************************************************
C* *
C* E R R T N *
C* *
C* FORTRAN USE procedure. *
C* *
C*******************************************************************************
IMPLICIT INTEGER (A-Z)
LOGICAL INVKEY, ENDSET, SIMDEL, OK, EXMS, DONE, FINAL
COMMON /EX/ EXMS
COMMON /ERBLK/ INVKEY, ENDSET, SIMDEL, OK, DONE
INTEGER VMSGS (51)
*DBMS
ACCESS SUB-SCHEMA Fortran-System-Programmer-SS OF SCHEMA Theme
PRIVACY KEY FOR COMPILE IS ACEDB.
DATA (VMSGS(I),I=1,51)/'Host ','Verbs',' ',
1 'Close',' Erro','r ', 'Delet','e Err','or ',
3 'Find ','Error',' ', ' ',' ',' ',
5 'Get E','rror ',' ', ' ',' ',' ',
7 'Inser','t Err','or ', 'Modif','y Err','or ',
9 'Open ','Error',' ', ' ',' ',' ',
1 'Remov','e Err','or ', 'Store',' Erro','r ',
3 ' ',' ',' ', ' ',' ',' ',
5 'Bind ','Error',' ', 'Call ','Error',' '/
INVKEY = .FALSE.
ENDSET = .FALSE.
SIMDEL = .FALSE.
OK = .FALSE.
IF (ERSTAT .NE. 240) GO TO 101
SIMDEL = .TRUE.
GO TO 999
101 IF (ERSTAT .NE. 307) GO TO 102
ENDSET = .TRUE.
GO TO 999
102 IF (ERSTAT .NE. 326) GO TO 103
INVKEY = .TRUE.
GO TO 999
103 IF (.NOT. EXMS) GO TO 998
VERB = ERSTAT / 100
MSG = ERSTAT - VERB*100
TYPE 104,(VMSGS((VERB-1)*3-1+I),I=1,3)
104 FORMAT (1X,3A5)
IF (VERB .EQ. 0 .OR. VERB .EQ. 1 .OR. VERB .EQ. 9) DONE = .TRUE.
IF (VERB .EQ. 15 .OR. VERB .EQ. 16) DONE = .TRUE.
IF (MSG .NE. 0) GO TO 801
TYPE 105
GO TO 998
801 IF (MSG .NE. 1) GO TO 802
TYPE 1
GO TO 998
802 IF (MSG .NE. 2) GO TO 803
TYPE 2
GO TO 998
803 IF (MSG .NE. 3) GO TO 804
TYPE 3
GO TO 998
804 IF (MSG .NE. 4) GO TO 805
TYPE 4
GO TO 998
805 IF (MSG .NE. 5) GO TO 806
TYPE 5
GO TO 998
806 IF (MSG .NE. 6) GO TO 807
TYPE 6
GO TO 998
807 IF (MSG .NE. 7) GO TO 808
TYPE 7
GO TO 998
808 IF (MSG .NE. 8) GO TO 809
TYPE 8
GO TO 998
809 IF (MSG .NE. 9) GO TO 810
TYPE 9
GO TO 998
810 IF (MSG .NE. 10) GO TO 811
TYPE 10
GO TO 998
811 IF (MSG .NE. 11) GO TO 812
TYPE 11
GO TO 998
812 IF (MSG .NE. 12) GO TO 813
TYPE 12
GO TO 998
813 IF (MSG .NE. 13) GO TO 814
TYPE 13
GO TO 998
814 IF (MSG .NE. 14) GO TO 815
TYPE 14
GO TO 998
815 IF (MSG .NE. 15) GO TO 816
TYPE 15
GO TO 998
816 IF (MSG .NE. 16) GO TO 817
TYPE 16
GO TO 998
817 IF (MSG .NE. 17) GO TO 818
TYPE 17
GO TO 998
818 IF (MSG .NE. 18) GO TO 819
TYPE 18
GO TO 998
819 IF (MSG .NE. 19) GO TO 820
C NO ERROR 19
GO TO 998
820 IF (MSG .NE. 20) GO TO 821
TYPE 20
GO TO 998
821 IF (MSG .NE. 21) GO TO 822
C NO ERROR 21
GO TO 998
822 IF (MSG .NE. 22) GO TO 823
TYPE 22
GO TO 998
823 IF (MSG .NE. 23) GO TO 824
TYPE 23
GO TO 998
824 IF (MSG .NE. 24) GO TO 825
TYPE 24
GO TO 998
825 IF (MSG .NE. 25) GO TO 826
TYPE 25
GO TO 998
826 IF (MSG .NE. 26) GO TO 827
TYPE 26
GO TO 998
827 IF (MSG .NE. 27) GO TO 828
C NO ERROR 27
GO TO 998
828 IF (MSG .NE. 28) GO TO 829
TYPE 28
GO TO 998
829 IF (MSG .NE. 29) GO TO 830
C NO ERROR 29
GO TO 998
830 IF (MSG .NE. 30) GO TO 831
TYPE 30
GO TO 998
831 IF (MSG .NE. 31) GO TO 832
TYPE 31
GO TO 998
832 IF (MSG .NE. 32) GO TO 833
TYPE 32
GO TO 998
833 IF (MSG .NE. 33) GO TO 834
TYPE 33
GO TO 998
834 IF (MSG .NE. 34) GO TO 835
TYPE 34
GO TO 998
835 IF (MSG .NE. 35) GO TO 836
TYPE 35
GO TO 998
836 IF (MSG .NE. 36) GO TO 837
TYPE 36
GO TO 998
837 IF (MSG .NE. 37) GO TO 838
TYPE 37
GO TO 998
838 IF (MSG .NE. 38) GO TO 839
TYPE 38
GO TO 998
839 IF (MSG .NE. 39) GO TO 840
TYPE 39
GO TO 998
840 IF (MSG .NE. 40) GO TO 841
TYPE 40
GO TO 998
841 IF (MSG .NE. 41) GO TO 842
TYPE 41
GO TO 998
842 IF (MSG .NE. 42) GO TO 843
TYPE 42
GO TO 998
843 IF (MSG .NE. 43) GO TO 844
TYPE 43
GO TO 998
844 IF (MSG .NE. 44) GO TO 845
TYPE 44
GO TO 998
845 IF (MSG .NE. 45) GO TO 846
TYPE 45
GO TO 998
846 IF (MSG .NE. 46) GO TO 847
C NO ERROR 46
GO TO 998
847 IF (MSG .NE. 47) GO TO 848
C NO ERROR 47
GO TO 998
848 IF (MSG .NE. 48) GO TO 849
C NO ERROR 48
GO TO 998
849 IF (MSG .NE. 49) GO TO 850
C NO ERROR 49
GO TO 998
850 IF (MSG .NE. 50) GO TO 851
C NO ERROR 50
GO TO 998
851 IF (MSG .NE. 51) GO TO 852
C NO ERROR 51
GO TO 998
852 IF (MSG .NE. 52) GO TO 853
C NO ERROR 52
GO TO 998
853 IF (MSG .NE. 53) GO TO 854
C NO ERROR 53
GO TO 998
854 IF (MSG .NE. 54) GO TO 855
C NO ERROR 54
GO TO 998
855 IF (MSG .NE. 55) GO TO 856
TYPE 55
GO TO 998
856 IF (MSG .NE. 56) GO TO 857
TYPE 56
GO TO 998
857 IF (MSG .NE. 57) GO TO 858
TYPE 57
GO TO 998
858 IF (MSG .NE. 58) GO TO 859
TYPE 58
GO TO 998
859 IF (MSG .NE. 59) GO TO 860
TYPE 59
GO TO 998
860 IF (MSG .NE. 60) GO TO 861
TYPE 60
GO TO 998
861 IF (MSG .NE. 61) GO TO 862
TYPE 61
GO TO 998
862 IF (MSG .NE. 62) GO TO 863
TYPE 62
GO TO 998
863 IF (MSG .NE. 63) GO TO 864
TYPE 63
GO TO 998
864 IF (MSG .NE. 64) GO TO 865
TYPE 64
GO TO 998
865 IF (MSG .NE. 65) GO TO 866
TYPE 65
GO TO 998
866 IF (MSG .NE. 66) GO TO 867
TYPE 66
GO TO 998
867 IF (MSG .NE. 67) GO TO 868
TYPE 67
GO TO 998
868 IF (MSG .NE. 68) GO TO 869
C NO ERROR 68
GO TO 998
869 IF (MSG .NE. 69) GO TO 998
C NO ERROR 69
998 FATAL = .TRUE.
TYPE 1000, ERSTAT, ERSET, ERREC, ERAREA, ERCNT
1000 FORMAT (/,' ERROR STATUS = ', I5, /,
1 ' ERROR SET = ', 6A5,/,
2 ' ERROR RECORD = ', 6A5,/,
3 ' ERROR AREA = ', 6A5,/,
4 ' ERROR COUNT = ', I10)
C ERROR MESSAGES
105 FORMAT (' A warning. Compile-time and run-time versions of',/,
1 ' schema differ.')
1 FORMAT (' Area not open.')
2 FORMAT (' Data base key inconsistent with area-name. Can also',/,
1 ' indicate that a referenced page number is in an area',/,
2 ' that is not in the invoked sub-schema.')
3 FORMAT (' Record affected (deleted or removed) by concurrent',/,
1 ' application.')
4 FORMAT (' Data name invalid or inconsistent. This can occur',/,
1 ' during GET or MODIFY with a data-name list.')
5 FORMAT (' Violation of DUPLICATES NOT ALLOWED clause.')
6 FORMAT (' Current of set, area, or record-name not known.')
7 FORMAT (' End of set, area, or record.')
8 FORMAT (' Referenced area, record, or set-name not in sub-',/,
1 ' schema. This may occur because:',/,
2 ' 1. DBCS encounters a record type not in the sub-',/,
3 ' schema when traversing a set.',/,
4 ' 2. Set type owned by the object record type is not',/,
5 ' in the sub-schema.',/,
6 ' 3. The VIA set is not in the sub-schema -- during set',/,
7 ' selection occurrence.',/,
8 ' 4. All subkeys are not in the sub-schema during CALC',/,
9 ' processing or searching a sorted set.',/,
1 ' 5. The sort key or a set not in the sub-schema is',/,
2 ' modified.')
9 FORMAT (' Update usage mode required. This is an attempt to',/,
1 ' use an updating verb when the specified area is open',/,
2 ' for retrieval.')
10 FORMAT (' Privacy breach attempted.')
11 FORMAT (' Physical space not available. No room remains for',/,
1 ' storing records. This can occur while DBCS is trying',/,
2 ' to store an internal record type such as an index',/,
3 ' or buoy.')
12 FORMAT (' Line numbers for data base keys are exhausted.')
13 FORMAT (' No current record of run-unit.')
14 FORMAT (' Object record is MANDATORY AUTOMATIC member of',/,
1 ' named set.')
15 FORMAT (' Oject record is MANDATORY type or not member type',/,
1 ' at all in named set. This is an attempt to REMOVE',/,
2 ' a record which is either a MANDATORY member or not',/,
3 ' a member of named set.')
16 FORMAT (' Record is already a member of named set.')
17 FORMAT (' Record has been deleted. This can occur during a',/,
1 ' FIND CURRENT of RECORD, SET, AREA, or RUN-UNIT',/,
2 ' or during a FIND NEXT of SET or AREA.')
18 FORMAT (' Data conversion unsuccessful.')
C NO ERROR 19
20 FORMAT (' Current record of run-unit not of correct record-',/,
1 ' type.')
C NO ERROR 21
22 FORMAT (' Record not currently member of named or implied set.')
23 FORMAT (' Illegal area-name passed in area identification.')
24 FORMAT (' Temporary and permanent areas referenced in same',/,
1 ' DML verb.')
25 FORMAT (' No set occurrence satisfies argument values. This',/,
1 ' can mean, for example, that the CALC value in the',/,
2 ' UWA matched no owner record.')
26 FORMAT (' No record satisfies RSE specified. This is a',/,
1 ' catch-all exception for the FIND verb.')
C NO ERROR 27
28 FORMAT (' Area already open.')
C NO ERROR 29
30 FORMAT (' Unqualified DELETE attempted on non-empty set.')
31 FORMAT (' Unable to open the Schema File.')
32 FORMAT (' Insufficient space allocated for the data-name.',/,
1 ' The SIZE clause specifies less space than the',/,
2 ' compiler needs.')
33 FORMAT (' None of the areas a record type can be within',/,
1 ' are in the sub-schema.')
34 FORMAT (' A set is in the sub-schema, but its owner record',/,
1 ' type is not.')
35 FORMAT (' Dynamic use-vector is full (FORTRAN ONLY).')
36 FORMAT (' Attempt to invoke too many sub-schemas (more than',/,
1 ' 8); or attempt to use UNSET with empty sub-schema',/,
2 ' stack, or SETDB with a full sub-schema stack.')
37 FORMAT (' Sub-schema passed to SETDB is not already invoked.')
38 FORMAT (' Duplicate operation attempted on a resource. This',/,
1 ' can occur because: 1) you attempt to open the',/,
2 ' journal file twice (you have opened it in EXCLUSIVE',/,
3 ' UPDATE usage-mode and are now opening a data area',/,
4 ' in UPDATE usage-mode), or 2) you call JSTRAN while',/,
5 ' a transaction is already active, or 3) you have',/,
6 ' multiple INVOKE statements and attempt to open',/,
7 ' the same area twice.')
39 FORMAT (' data base file not found.')
40 FORMAT (' Request access conflicts with existing access; that',/,
1 ' is, resource is not available. This can result from',/,
2 ' an attempt to:',/,
3 ' 1. Open an area in a USAGE-MODE incompatible with',/,
4 ' that of another run-unit using the same area.',/,
5 ' 2. Open the journal in a way that results in a',/,
6 ' USAGE-MODE conflict.',/,
7 ' 3. DELETE a record retained by another run-unit.',/,
8 ' 4. Attempt to open area or the journal and the',/,
9 ' file system signals a file-protection error.')
41 FORMAT (' No JFNs available. An attempt to open too many areas.')
42 FORMAT (' Area in undefined state. Use DBMEND to force open',/,
1 ' the area and return it to a valid state.')
43 FORMAT (' Area in creation state. This can happen to the',/,
1 ' system area only. This will occur if run-unit',/,
2 ' execution aborts at just the right time during',/,
3 ' the first OPEN of the system area. Should this occur',/,
4 ' either rerun SCHEMA or create a 0-length file with',/,
5 ' a text editor.')
44 FORMAT (' Attempt to call a journal-processing entry point',/,
1 ' before the journalling system has been initialized',/,
2 ' (by the first OPEN that requires journalling).')
45 FORMAT (' Attempt to backup the database with JBTRAN 1)',/,
1 ' while DBCS''s Cannot-Backup-Updates bit is set, or',/,
2 ' 2) when the journal is shared and commands are the',/,
3 ' interleaving unit, or 3) when the journal is shared,',/,
4 ' transactions are the interleaving unit, and the',/,
5 ' argument given to JBTRAN is greater than 0.')
C NO ERROR 46
C NO ERROR 47
C NO ERROR 48
C NO ERROR 49
C NO ERROR 50
C NO ERROR 51
C NO ERROR 52
C NO ERROR 53
C NO ERROR 54
55 FORMAT (' Pseudo-exception. DBCS types message that no',/,
1 ' sub-schema yet initialized.')
56 FORMAT (' Inconsistent data in the data base file. DBMEND',/,
1 ' should be used to restore the data base to a valid',/,
2 ' state. If the problem can be reproduced, it',/,
3 ' probably indicates a DBCS software error.')
57 FORMAT (' Probably a DBCS software error. If this recurs,',/,
1 ' report it.')
58 FORMAT (' Illegal argument passed by programmer or setup',/,
1 ' host interface; for example, passing a set-name',/,
2 ' with the STORE command.')
59 FORMAT (' No more memory available.')
60 FORMAT (' Unable to access a database file. The operating',/,
1 ' system reported an I/O error, either in normal',/,
2 ' operations or in trying to open a journal for',/,
3 ' appending.')
61 FORMAT (' Unable to append to journal (that is, the journal',/,
1 ' is in an aborted state but has not been designated',/,
2 ' as being done with).')
62 FORMAT (' Attempt to enter DBCS at other than JBTRAN, SBIND,',/,
1 ' SETDB, or UNSET while the system-in-undefined-state',/,
2 ' bit is on.')
63 FORMAT (' Unable to complete restoration of the proper data',/,
1 ' base state. This occurs either during JBTRAN',/,
2 ' initialization of a run-unit at the start of a ',/,
3 ' command or transaction.')
64 FORMAT (' Exceptions while processing exception.')
65 FORMAT (' Monitor space for ENQUEUE entries exhausted, or',/,
1 ' ENQUEUE quota exceeded.')
66 FORMAT (' ENQUEUE/DEQUEUE failure (for example, you do not',/,
1 ' have ENQUEUE capabilities, or an unacceptable',/,
2 ' argument block has been created by DBCS).')
67 FORMAT (' Unable to initialize magnetic tape service because,',/,
1 ' for example, the IPCF block is bad; the IPCF',/,
2 ' message is too long; or DAEMDB is not running.')
C NO ERROR 68
C NO ERROR 69
999 RETURN
*DBMS
END ERRTN.