-
Notifications
You must be signed in to change notification settings - Fork 4
/
netlib_get_version.b32
executable file
·171 lines (154 loc) · 3.13 KB
/
netlib_get_version.b32
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
%TITLE 'NETLIB_GET_VERSION'
MODULE NETLIB_GET_VERSION (IDENT='V1.0', ADDRESSING_MODE (EXTERNAL=GENERAL), MAIN=NETLIB_GET_VERSION) =
BEGIN
!++
! FACILITY: NETLIB
!
! ABSTRACT: abstract
!
! MODULE DESCRIPTION:
!
! description
!
! AUTHOR: M. Madison
! COPYRIGHT © 1998, MADGOAT SOFTWARE, INC. ALL RIGHTS RESERVED.
!
! CREATION DATE: 23-APR-1998
!
! MODIFICATION HISTORY:
!
! 23-APR-1998 V1.0 Madison Initial coding.
!--
LIBRARY 'SYS$LIBRARY:STARLET';
FORWARD ROUTINE
NETLIB_GET_VERSION,
get_version_routine,
find_image_symbol;
EXTERNAL ROUTINE
LIB$SIG_TO_RET,
LIB$FIND_IMAGE_SYMBOL,
LIB$SET_SYMBOL;
EXTERNAL LITERAL
LIB$_KEYNOTFOU;
%SBTTL 'NETLIB_GET_VERSION'
GLOBAL ROUTINE NETLIB_GET_VERSION =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! description
!
! RETURNS: cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
! NETLIB_GET_VERSION
!
! IMPLICIT INPUTS: None.
!
! IMPLICIT OUTPUTS: None.
!
! COMPLETION CODES:
!
! SS$_NORMAL: normal successful completion.
!
! SIDE EFFECTS:
!
! None.
!--
LOCAL
dsc : BLOCK [DSC$K_S_BLN,BYTE],
buf : VECTOR [64,BYTE],
len : WORD,
rtnptr,
status;
dsc [DSC$B_DTYPE] = DSC$K_DTYPE_T;
dsc [DSC$B_CLASS] = DSC$K_CLASS_S;
dsc [DSC$W_LENGTH] = %ALLOCATION (buf);
dsc [DSC$A_POINTER] = buf;
status = get_version_routine (rtnptr);
IF .status THEN
status = (.rtnptr)(dsc, len)
ELSE if .status EQL LIB$_KEYNOTFOU THEN
BEGIN
BIND old = %ASCID'NETLIB V2.1 or earlier' : BLOCK [,BYTE];
dsc [DSC$W_LENGTH] = .old [DSC$W_LENGTH];
CH$MOVE (.dsc [DSC$W_LENGTH], .old [DSC$A_POINTER], .dsc [DSC$A_POINTER]);
status = SS$_NORMAL;
END
ELSE
dsc [DSC$W_LENGTH] = 0;
IF .status THEN
BEGIN
dsc [DSC$A_POINTER] = CH$PLUS (buf, 7);
dsc [DSC$W_LENGTH] = 1;
END;
LIB$SET_SYMBOL (%ASCID'NETLIB_OLD_V_TAG', dsc);
IF .status THEN
BEGIN
dsc [DSC$A_POINTER] = CH$PLUS (buf, 8);
dsc [DSC$W_LENGTH] = .len - 8;
END;
LIB$SET_SYMBOL (%ASCID'NETLIB_OLD_VERSION', dsc);
SS$_NORMAL
END; ! NETLIB_GET_VERSION
%SBTTL 'get_version_routine'
ROUTINE get_version_routine (rtnptr_a) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! description
!
! RETURNS: cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
! x
!
! IMPLICIT INPUTS: None.
!
! IMPLICIT OUTPUTS: None.
!
! COMPLETION CODES:
!
! SS$_NORMAL: normal successful completion.
!
! SIDE EFFECTS:
!
! None.
!--
ENABLE
LIB$SIG_TO_RET;
find_image_symbol (%ASCID'NETLIB_SHRXFR', %ASCID'NETLIB_VERSION', .rtnptr_a)
END; ! get_version_routine
%SBTTL 'find_image_symbol'
ROUTINE find_image_symbol (img_a, sym_a, val_a) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! description
!
! RETURNS: cond_value, longword (unsigned), write only, by value
!
! PROTOTYPE:
!
! x
!
! IMPLICIT INPUTS: None.
!
! IMPLICIT OUTPUTS: None.
!
! COMPLETION CODES:
!
! SS$_NORMAL: normal successful completion.
!
! SIDE EFFECTS:
!
! None.
!--
LIB$FIND_IMAGE_SYMBOL (.img_a, .sym_a, .val_a)
END; ! find_image_symbol
END
ELUDOM