1 03/06/80 apl_erf_.pl1.info
2
3 Function: This info segment gives a sample pl1 program than can be called as an
4 external function from within apl. The sample program is a monadic, scalar
5 function meaning that it is called with exactly one argument that it operates
6 on each element of the input argument independently of the other elements and
7 that the shape of the result is the same as the shape of the input argument.
8 The sample program computes the "error function" of its input argument,
9 using the PL/I builtin "erf".
10
11 The sample program may be extracted from this info segment, compiled and
12 executed, if desired. The necessary include segments are located in the
13 directory >ldd>unbundled>include except at MIT where they are in
14 >ldd>include.
15
16
17 Text of PL/I program:
18 /* ******************************************************
19 * *
20 * *
21 * Copyright c 1972 by Massachusetts Institute of *
22 * Technology and Honeywell Information Systems, Inc. *
23 * *
24 * *
25 ****************************************************** */
26
27 /* APL External Function to implement the PL/I 'erf' builtin for APL */
28 /* Written October 15, 1975 by Paul Green */
29 /* Modified 780927 by PG to fix bug 335 type field of result not being setup properly.
30 Also switched to apl_push_stack_ subroutine. */
31
32 /* format: style3 */
33 apl_erf_:
34 procedure operators_argument;
35
36 /* automatic */
37
38 declare n_words fixed bin 19, /* number of words to allocate on value stack */
39 result ptr, /* pointer to result data array */
40 result_vb ptr, /* pointer to result value bead */
41 right ptr, /* pointer to right data array */
42 right_vb ptr; /* pointer to right value bead */
43
44 /* builtins */
45
46 declare addrel erf size string substr rel
47 builtin;
48
49 /* include files */
50
51 %include apl_external_function;
52 %page;
53 /* program */
54
55 /* Usage in APL:
56 )MFN ERF APL_ERF_
57 RESULT -^H< ERF V */
58
59 right_vb = operators_argument.operands 2.value; /* Get ptr to right argument */
60 if ^right_vb -> value_bead.value /* Make sure argument is a value bead */
61 then go to domain_error_right;
62
63 if ^right_vb -> value_bead.numeric_value /* Make sure argument is numeric */
64 then go to domain_error_right;
65
66 right = right_vb -> value_bead.data_pointer; /* Point to data array */
67 data_elements = right_vb -> value_bead.total_data_elements;
68
69 if operators_argument.operands 2.on_stack
70 then do;
71
72 /* overwrite operand with result */
73
74 result_vb = right_vb;
75 result = right;
76 end;
77 else do;
78
79 /* Right operand isn't on stack...can't overlay...build new result bead. */
80
81 /* Calculate size of result bead. Note that result data array */
82 /* must be double-word aligned. */
83
84 number_of_dimensions = right_vb -> value_bead.rhorho;
85 n_words = size value_bead + size numeric_datum + 1;
86
87 /* Allocate space on the value stack for the result bead. */
88
89 result_vb = apl_push_stack_ n_words;
90
91 /* Set pointer to data array. Double-word align it. */
92
93 result = addrel result_vb size value_bead;
94
95 if substr rel result 18 1
96 then result = addrel result 1;
97
98 /* Initialize new value bead. */
99
100 result_vb -> value_bead.total_data_elements = data_elements;
101 result_vb -> value_bead.rhorho = number_of_dimensions;
102 result_vb -> value_bead.data_pointer = result;
103
104 if number_of_dimensions > 0 /* Zero-length arrays are invalid in PL/I, so check first */
105 then result_vb -> value_bead.rho * = right_vb -> value_bead.rho *;
106 end;
107
108 /* Give result bead the correct data type */
109
110 string result_vb -> value_bead.type = numeric_value_type;
111
112 /* The result value bead is all set up. Perform the operation */
113
114 result -> numeric_datum * = erf right -> numeric_datum *;
115
116 operators_argument.result = result_vb;
117 return;
118
119 domain_error_right:
120 operators_argument.where_error = operators_argument.where_error - 1;
121 /* Mark right operand */
122 operators_argument.error_code = apl_error_table_$domain;
123 return;
124 %page;
125 %include apl_push_stack_fcn;
126 end /* apl_erf_ */;