Adabas ダイレクトコールを使用する VAX-11 MACRO の例です。付録 B で定義された Adabas ファイルが使用されています。
.TITLE EXAMPLE ADABAS (OpenVMS) example program
;******************************************************** ;* * ;* A D A B A S / V M S MACRO example program * ;* ------------------------------------------- * ;* * ;* Assemble, link and run this program by typing: * ;* * ;* $ MACRO EXAMPLE * ;* $ LINK EXAMPLE * ;* $ RUN EXAMPLE * ;* * ;* Function: * ;* * ;* Find in the default database all people * ;* named 'SMITH' and increase their salary * ;* by 10% * ;* * ;********************************************************
.DEFAULT DISPLACEMENT WORD
.EXTERNAL ADABAS,LIB$PUT_OUTPUT
EXAMPLE_DB = 0 ; Use default database PERSON_FILE = 11 ; and example file 'EMPLOYEES'
.PSECT CONSTANT,NOEXE,NOWRT
FB: .ASCII /ASN,4,F./ ; Format Buffer : L_FB = .-FB ; Salary as 4 byte integer
SB: .ASCII /AE,5./ ; Search Buffer : L_SB = .-SB ; Searching via name
VB: .ASCII /SMITH/ ; Value Buffer : L_VB = .-VB ; Searching for 'SMITH'
TXT_START: .ASCID /MACRO example program for calling ADABAS (OpenVMS)/ TXT_RESP: .ASCID /** Response code !UW from ADABAS for command !AD/ TXT_FOUND: .ASCID /Found : !5UL records/ TXT_SALARY: .ASCID / ISN !8UL old salary = !10UL new salary = !10UL/
.PSECT VARIABLE,PIC,NOEXE
CB: ; Control block
.BLKB 2
COMMAND_CODE: .BLKB 2
COMMAND_ID: .BLKB 4
FILE_NUMBER: .BLKB 1
DB_ID: .BLKB 1
RESPONSE_CODE: .BLKW 1
ISN: .BLKL 1
ISN_LL: .BLKL 1
ISN_QUANTITY: .BLKL 1
FMT_BUF_LNG: .BLKW 1
REC_BUF_LNG: .BLKW 1
SEA_BUF_LNG: .BLKW 1
VAL_BUF_LNG: .BLKW 1
ISN_BUF_LNG: .BLKW 1
CMD_OPT_1: .BLKB 1
CMD_OPT_2: .BLKB 1
ADDITIONS_1: .BLKB 8
ADDITIONS_2: .BLKB 4
ADDITIONS_3: .BLKB 8
ADDITIONS_4: .BLKB 8
ADDITIONS_5: .BLKB 8
COMMAND_TIME: .BLKL 1
USER_AREA: .BLKB 4
IB: .BLKL 1 ; ISN Buffer :
L_IB = .-IB ; Reserves space for 1 ISN
ADAPAR: .BLKL 7 ; ADABAS parameter list
FAOPAR: .BLKL 4 ; FAO parameter list
OUTDESC: .BLKL 2 ; Descriptor of formatting buffer
OUTBUF: .BLKB 80 ; Formatting buffer L_OUTBUF= .-OUTBUF
RB: .ASCII /UPD=11./ ; Record Buffer : L_RB_OP = .-RB ; Open file 11 for update . = RB SALARY: .BLKL 1 ; Overlay SALARY L_RB = .-RB
.PSECT CODE,EXE,NOWRT
.ENTRY EXAMPLE,^M<>
MOVAB TXT_START,FAOPAR ; Display
BSBW WRITE_LINE ; startup message
BSBB OPEN_DATABASE ; Open successful ?
BNEQ 40$ ; No
CLRL R3 ; Update count
BSBW FIND_RECORD ; Initial find successful ?
BNEQ 20$ ; No
MOVAB TXT_FOUND,FAOPAR ; Display
MOVL ISN_QUANTITY,FAOPAR+4 ; no. of records found
BSBW WRITE_LINE
TSTL ISN_QUANTITY ; Any records?
BEQL 30$ ; No
10$:
MOVL SALARY,R2 ; Save old salary
BSBW UPDATE_RECORD ; Salary updated successful ?
BNEQ 20$ ; No
MOVAB TXT_SALARY,FAOPAR
MOVL ISN,FAOPAR+4 ; Display
MOVL R2,FAOPAR+8 ; ISN, old and new salary
MOVL SALARY,FAOPAR+12
BSBW WRITE_LINE
INCL R3 ; No. of records updated
BSBW FIND_RECORD ; Subsequent find successful ?
BEQL 10$ ; Yes
CMPW RESPONSE_CODE,#3 ; End of ISN list ?
BEQL 30$ ; Yes
20$:
BSBW RESPONSE ; Display response
TSTL R3 ; Any modifications made ?
BEQL 30$ ; No
BSBB ISSUE_BT ; Backout transaction successful ?
BNEQ 40$ ; No
CLRL R3 ; Nothing has changed
30$:
BSBB CLOSE_DATABASE ; Close successful ?
BEQL 999$ ; Yes
40$:
BSBW RESPONSE ; Display response code
999$:
RET
OPEN_DATABASE:
MOVB #EXAMPLE_DB,DB_ID ; Example database
MOVW #^A/OP/,COMMAND_CODE
MOVW #L_RB_OP,REC_BUF_LNG ; 'Open' Record Buffer length
10$:
PUSHAB RB ; Record Buffer adr.
CLRL -(SP) ; No Format Buffer
PUSHAB CB ; Control Block adr.
CALLS #3,G^ADABAS ; OPEN, UPDATE=EMPLOYEES_FILE
CMPW RESPONSE_CODE,#9 ; Response 9 ?
BEQL 10$ ; Yes
TSTW RESPONSE_CODE ; Set condition code
RSB
CLOSE_DATABASE:
MOVW #^A/CL/,COMMAND_CODE
PUSHAB CB ; Control Block adr.
CALLS #1,G^ADABAS ; CLOSE
TSTW RESPONSE_CODE ; Set condition code
RSB
ISSUE_BT:
MOVW #^A/BT/,COMMAND_CODE
PUSHAB CB ; Control Block adr.
CALLS #1,G^ADABAS ; Backout transaction
TSTW RESPONSE_CODE ; Set condition code
RSB
FIND_RECORD:
MOVW #^A/L4/,COMMAND_CODE
TSTL ISN_QUANTITY ; Initial call ?
BNEQ 10$ ; No
MOVW #^A/S4/,COMMAND_CODE
MOVB #EMPLOYEES_FILE,-
FILE_NUMBER ; Search in file 'EMPLOYEES'
MOVL #^A/FIND/,COMMAND_ID
MOVW #L_FB,FMT_BUF_LNG ; Set-up
MOVW #L_RB,REC_BUF_LNG ; buffer lengths
MOVW #L_SB,SEA_BUF_LNG
MOVW #L_VB,VAL_BUF_LNG
MOVW #L_IB,ISN_BUF_LNG
MOVB #^A/N/,CMD_OPT_2
MOVAB CB,ADAPAR+4 ; Set-up
MOVAB FB,ADAPAR+8 ; ADABAS parameter block
MOVAB RB,ADAPAR+12
MOVAB SB,ADAPAR+16
MOVAB VB,ADAPAR+20
MOVAB IB,ADAPAR+24
10$:
MOVL #6,ADAPAR ; CB, FB, RB, SB, VB, IB used
CALLG ADAPAR,G^ADABAS ; Find next EMPLOYEES
with NAME = 'SMITH'
TSTW RESPONSE_CODE ; Set condition code
RSB
UPDATE_RECORD:
DIVL3 #10,SALARY,R0 ; Increase
ADDL2 R0,SALARY ; salary by 10%
MOVW #^A/A1/,COMMAND_CODE
MOVL #3,ADAPAR ; CB, FB, RB used
CALLG ADAPAR,G^ADABAS ; Update salary
TSTW RESPONSE_CODE ; Set condition code
RSB
RESPONSE:
MOVAB TXT_RESP,FAOPAR
MOVZWL RESPONSE_CODE,FAOPAR+4 ; Display
MOVL #2,FAOPAR+8 ; ADABAS response code
MOVAB COMMAND_CODE,FAOPAR+12
BSBB WRITE_LINE
RSB
WRITE_LINE:
MOVL #L_OUTBUF,OUTDESC ; Output buffer
MOVAB OUTBUF,OUTDESC+4 ; length and adr.
$FAOL_S @FAOPAR,OUTDESC,- ; Formatting of output successful ?
OUTDESC,FAOPAR+4
BLBC R0,10$ ; No
PUSHAQ OUTDESC
CALLS #1,G^LIB$PUT_OUTPUT ; Output written successful ?
BLBC R0,10$ ; No
RSB
10$:
$EXIT_S R0
.END EXAMPLE