1 PACKAGE BODY diutil IS
2
3 defvaloption_ignore CONSTANT NUMBER := 0;
4 defvaloption_full CONSTANT NUMBER := 1;
5 defvaloption_default_comment CONSTANT NUMBER := 2;
6
7 -----------------------
8 -- PRIVATE members
9 -----------------------
10
11 PROCEDURE diugdn(name VARCHAR2, usr VARCHAR2, dbname VARCHAR2,
12 dbowner VARCHAR2, status OUT ub4, nod OUT ptnod,
13 libunit_type BINARY_INTEGER,
14 load_source BINARY_INTEGER);
15 PRAGMA interface(c,diugdn);
16 PROCEDURE diustx(n ptnod, txt OUT VARCHAR2, status OUT ub4);
17 PRAGMA interface(c,diustx);
18
19 assertval CONSTANT BOOLEAN := true;
20
21 -----------------------
22 -- assert
23 -----------------------
24 PROCEDURE assert(v BOOLEAN, str VARCHAR2) IS
25 x INTEGER;
26 BEGIN
27 IF (assertval AND NOT v) THEN
28 RAISE program_error;
29 END IF;
30 END assert;
31
32 -----------------------
33 -- assert
34 -----------------------
35 PROCEDURE assert(v BOOLEAN) IS
36 BEGIN
37 assert(v, '');
38 END;
39
40 -----------------------
41 -- last_elt
42 -----------------------
43 FUNCTION last_elt (seq pidl.ptseqnd) RETURN pidl.ptnod IS
44 len BINARY_INTEGER;
45 BEGIN
46 len := pidl.ptslen(seq);
47 assert(len > 0);
48 RETURN pidl.ptgend(seq, len - 1);
49 END last_elt;
50
51 -----------------------
52 -- normalname: RETURN a normalized name. fold up IF NOT IN quotes,
53 -- ELSE strip quotes.
54 -----------------------
55 FUNCTION normalname(name VARCHAR2) RETURN VARCHAR2 IS
56 firstchar VARCHAR2(4);
57 len NUMBER;
58 BEGIN
59 IF (name IS NULL OR name = '') THEN RETURN name; END IF;
60 firstchar := substr(name, 1, 1);
61 IF (firstchar = '"') THEN
62 len := length(name);
63 IF (len > 1 AND substr(name, len, 1) = '"') THEN
64 IF (len > 33) THEN
65 len := 31;
66 ELSE
67 len := len-2;
68 END IF;
69 RETURN substr(name, 2, len);
70 END IF;
71 END IF;
72 RETURN upper(name);
73 END normalname;
74
75 -----------------------
76 -- coatname: enquote name IF necessary
77 -----------------------
78 FUNCTION coatname(name VARCHAR2) RETURN VARCHAR2 IS
79 BEGIN
80 IF (name <> upper(name)) THEN
81 RETURN '"' || name || '"';
82 ELSIF char_for_varchar2 AND name = 'VARCHAR2' THEN
83 RETURN 'CHAR';
84 ELSE
85 RETURN name;
86 END IF;
87 END coatname;
88
89 -----------------------
90 -- idname
91 -----------------------
92 FUNCTION idname(n ptnod) RETURN VARCHAR2 IS
93 -- RETURN the text OF an id node. this FUNCTION IS also
94 -- used TO limit the recursion IN exprtext() below.
95 -- should have the semantics OF listtext(diana.as_list(n), ',');
96 seq pidl.ptseqnd;
97 BEGIN
98 assert(pidl.ptkin(n) = diana.ds_id);
99 seq := diana.as_list(n);
100 RETURN coatname(diana.l_symrep(last_elt(seq)));
101 END idname;
102
103 -----------------------
104 -- exprtext: general unparsing FUNCTION
105 -----------------------
106 PROCEDURE exprtext(x ptnod, rv IN OUT VARCHAR2);
107
108 -----------------------
109 -- genprocspec
110 -- append the spec FOR a top-LEVEL node n TO stext.
111 -- defvaloption controls whether parm DEFAULT vals should be ignored,
112 -- printed fully OR flagged IN comments AS "defaulted"
113 -- hasdefval returned true iff parm DEFAULT vals exist.
114 -- toplevel name returned IN pname.
115 -- IF FUNCTION, FUNCTION STRING returned IN returnval.
116 -----------------------
117 PROCEDURE genprocspec(n ptnod,
118 defvaloption NUMBER,
119 hasdefval IN OUT BOOLEAN,
120 pname IN OUT VARCHAR2,
121 returnval IN OUT VARCHAR2,
122 flags VARCHAR2,
123 stext IN OUT VARCHAR2);
124
125
126 -----------------------
127 -- procname
128 -----------------------
129 FUNCTION procname(k ptnod) RETURN VARCHAR2 IS
130 x ptnod; xkind pidl.ptnty;
131 BEGIN
132 IF (k IS NULL OR k = 0) THEN RETURN NULL; END IF;
133 IF (pidl.ptkin(k) <> diana.d_s_decl) THEN RETURN NULL; END IF;
134 x := diana.a_d_(k);
135 xkind := pidl.ptkin(x);
136 IF ( xkind <> diana.di_funct
137 AND xkind <> diana.di_proc
138 AND xkind <> diana.d_def_op) THEN
139 RETURN NULL;
140 END IF;
141 RETURN diana.l_symrep(x);
142 END;
143
144
145 -----------------------
146 -- PRIVATE members
147 -----------------------
148
149
150 -----------------------
151 -- get_d
152 -----------------------
153 PROCEDURE get_d (name VARCHAR2, usr VARCHAR2, dbname VARCHAR2,
154 dbowner VARCHAR2, status IN OUT ub4, nod OUT ptnod,
155 libunit_type NUMBER := libunit_type_spec,
156 load_source NUMBER := load_source_no) IS
157 nname VARCHAR2(100);
158 nusr VARCHAR2(100);
159 ndbname VARCHAR2(100);
160 ndbowner VARCHAR2(100);
161 BEGIN -- get_d
162 nod := NULL;
163 BEGIN
164 nname := normalname(name);
165 nusr := normalname(usr);
166 ndbname := normalname(dbname);
167 ndbowner := normalname(dbowner);
168 IF (nname IS NULL OR nname = '') THEN
169 RAISE e_subpnotfound;
170 END IF;
171 diugdn(nname, nusr, ndbname, ndbowner, status, nod,
172 libunit_type, load_source);
173
174 IF (status = 1) THEN
175 diugdn(nname, '', ndbname, ndbowner, status, nod,
176 libunit_type, load_source);
177 END IF;
178
179 IF (status = 1) THEN
180 RAISE e_subpnotfound;
181 ELSIF (status = 2) THEN
182 RAISE e_nopriv;
183 ELSIF (status <> 0) THEN
184 RAISE e_other;
185 END IF;
186 status := s_ok;
187 EXCEPTION
188 WHEN e_subpnotfound THEN
189 status := s_subpnotfound;
190 WHEN e_nopriv THEN
191 status := s_subpnotfound;
192 WHEN OTHERS THEN
193 status := s_other;
194 END;
195 END get_d;
196
197 -----------------------
198 -- get_diana
199 -----------------------
200 PROCEDURE get_diana (name VARCHAR2, usr VARCHAR2, dbname VARCHAR2,
201 dbowner VARCHAR2,
202 status IN OUT ub4, nod IN OUT ptnod,
203 libunit_type NUMBER := libunit_type_spec,
204 load_source NUMBER := load_source_no) IS
205 t ptnod;
206 BEGIN -- get_diana
207 nod := NULL;
208 BEGIN
209 get_d(name, usr, dbname, dbowner, status, nod,
210 libunit_type, load_source);
211 IF (status = s_ok) THEN
212 t := diana.a_unit_b(nod);
213 assert(pidl.ptkin(t) <> diana.q_create);
214 END IF;
215 EXCEPTION
216 WHEN program_error THEN
217 status := s_other;
218 WHEN OTHERS THEN
219 status := s_other;
220 END;
221 END get_diana;
222
223
224 -----------------------
225 -- subptxt
226 -----------------------
227 PROCEDURE subptxt(name VARCHAR2, subname VARCHAR2, usr VARCHAR2,
228 dbname VARCHAR2, dbowner VARCHAR2, txt IN OUT VARCHAR2,
229 status IN OUT ub4) IS
230 e_defaultval BOOLEAN := false;
231
232 -----------------------
233 -- describeproc
234 -----------------------
235 PROCEDURE describeproc(n ptnod, s IN OUT VARCHAR2) IS
236 tmpval VARCHAR2(100);
237 rval VARCHAR2(500);
238 BEGIN -- describeproc
239 -- we call genprocspec here because it IS NOT
240 -- possible TO get the text reliably FOR arbitrary node
241 -- through diustx
242 --
243 tmpval := NULL;
244 genprocspec(n, defvaloption_default_comment,
245 e_defaultval, tmpval, rval, '', s);
246 s := s || '; ';
247 END describeproc;
248
249 BEGIN -- subptxt
250 txt := '';
251
252 DECLARE
253 troot ptnod;
254 n ptnod;
255 nsubname VARCHAR2(100);
256 BEGIN
257 get_diana(name, usr, dbname, dbowner, status, troot,
258 libunit_type_spec, load_source_yes);
259 IF (troot IS NULL OR troot = 0) THEN RETURN; END IF;
260
261 nsubname := normalname(subname);
262 n := diana.a_unit_b(troot);
263
264 IF (nsubname IS NULL OR nsubname = '') THEN
265 IF ((pidl.ptkin(n) = diana.d_p_decl) OR
266 (pidl.ptkin(n) = diana.d_library)) THEN
267 diustx(troot, txt, status);
268 ELSE
269 describeproc(n, txt);
270 END IF;
271 ELSE
272 -- search FOR subname among ALL func/proc IN the PACKAGE
273 IF (pidl.ptkin(n) <> diana.d_p_decl) THEN
274 status := s_subpnotfound;
275 RETURN;
276 END IF;
277 n := diana.a_packag(n);
278 DECLARE
279 seq pidl.ptseqnd := diana.as_list(diana.as_decl1(n));
280 len INTEGER := pidl.ptslen(seq) - 1;
281 tmp INTEGER;
282 BEGIN
283 FOR i IN 0..len LOOP --FOR each MEMBER OF the PACKAGE
284 n := pidl.ptgend(seq, i);
285 IF (procname(n) = nsubname) THEN
286 describeproc(n, txt);
287 END IF;
288 END LOOP;
289 END;
290 IF (txt IS NULL OR txt = '') THEN
291 status := s_notinpackage;
292 END IF;
293 END IF;
294
295 EXCEPTION -- txt reset TO NULL
296 WHEN value_error THEN
297 status := s_stubtoolong;
298 WHEN program_error THEN
299 status := s_logic;
300 WHEN e_other THEN
301 status := s_other;
302 WHEN OTHERS THEN
303 status := s_other;
304 END;
305 END subptxt;
306
307
308 -----------------------------------------------------------------------
309 -- PRIVATE implementations
310 -----------------------------------------------------------------------
311
312
313 --------------------
314 -- exprtext:
315 -- general unparsing FUNCTION
316 --------------------
317 PROCEDURE exprtext(x ptnod, rv IN OUT VARCHAR2) IS
318
319 --------------------
320 -- etext:
321 --------------------
322 PROCEDURE etext(n ptnod);
323
324 --------------------
325 -- listtext
326 --------------------
327 PROCEDURE listtext(seq pidl.ptseqnd, spc VARCHAR2) IS
328 len INTEGER;
329 BEGIN
330 len := pidl.ptslen(seq);
331 IF (len >= 1) THEN
332 etext(pidl.ptgend(seq, 0));
333 len := len - 1;
334 FOR i IN 1..len LOOP
335 rv := rv || spc;
336 etext(pidl.ptgend(seq, i));
337 END LOOP;
338 END IF;
339 END;
340
341 --------------------
342 -- etext:
343 --------------------
344 PROCEDURE etext(n ptnod) IS
345 nkind pidl.ptnty;
346 BEGIN
347 IF (n IS NOT NULL) THEN
348 nkind := pidl.ptkin(n);
349 -- simple expr
350 IF (nkind = diana.di_u_nam OR nkind = diana.d_used_b
351 OR nkind = diana.di_u_blt OR nkind = diana.di_funct
352 OR nkind = diana.di_proc OR nkind = diana.di_packa
353 OR nkind = diana.di_var OR nkind = diana.di_type
354 OR nkind = diana.di_subty OR nkind = diana.di_in
355 OR nkind = diana.di_out OR nkind = diana.di_in_ou) THEN
356 rv := rv || coatname(diana.l_symrep(n));
357
358 ELSIF (nkind = diana.d_s_ed) THEN
359 -- x.y
360 etext(diana.a_name(n));
361 rv := rv || '.';
362 etext(diana.a_d_char(n));
363
364 ELSIF (nkind = diana.d_string OR nkind = diana.d_used_c
365 OR nkind = diana.d_def_op) THEN
366 rv := rv || '''' || diana.l_symrep(n) || '''';
367
368 ELSIF (nkind = diana.d_attrib) THEN
369 -- x.y%TYPE
370 -- simply ADD the %TYPE text rather than try TO resolve
371 -- it TO get the name OF the TYPE
372 --
373 etext(diana.a_name(n));
374 rv := rv || '%';
375 etext(diana.a_id(n));
376
377 ELSIF (nkind = diana.d_numeri) THEN
378 rv := rv || diana.l_numrep(n);
379
380 ELSIF (nkind = diana.d_null_a) THEN
381 rv := rv || 'null';
382
383 ELSIF (nkind = diana.d_constr) THEN -- constraint
384 etext(diana.a_name(n));
385 -- -- Function params and returns do not accept constraints directly.
389 -- END IF;
386 -- IF (diana.a_constt(n) IS NOT NULL AND diana.a_constt(n) <> 0) THEN
387 -- rv := rv || ' ';
388 -- etext(diana.a_constt(n));
390 IF (diana.a_constt(n) IS NOT NULL AND diana.a_constt(n) <> 0) THEN
391 RAISE e_notv6compat;
392 END IF;
393 IF (diana.a_cs(n) IS NOT NULL) THEN
394 IF ((diana.s_charset_form(diana.a_cs(n)) = 1) OR
395 (diana.s_charset_form(diana.a_cs(n)) = 4)) THEN
396 -- SQLCS_IMPLICIT: don't need to mark anything.
397 -- SQLCS_FLEXIBLE: for now, don't mark anything. If we ever
398 -- need to support v8 clients, for those we'd want marking.
399 NULL;
400 ELSE
401 -- SQLCS_NCHAR and SQLCS_EXPLICIT cases are not usable by v6
402 -- or v7 clients. SQLCS_LIT_NULL should never occur as the
403 -- type of a formal or result. Anything else is really bogus.
404 RAISE e_notv6compat;
405 END IF;
406 END IF;
407
408 /*
409 -- 14jul92 =g=> many OF these remaining cases BY an work,
410 -- but aren't needed.
411
412 -- implicit conversion
413 ELSIF (nkind = diana.d_parm_c) THEN
414 DECLARE seq pidl.ptseqnd := diana.as_list(diana.as_p_ass(n));
415 BEGIN
416 etext(last_elt(seq));
417 END;
418
419 -- arglist
420 ELSIF (nkind = diana.ds_apply) THEN
421 DECLARE aseq ptnod := diana.as_list(n); BEGIN
422 rv := rv || '(';
423 listtext(aseq, ',');
424 rv := rv || ')';
425 END;
426
427 -- d_f_call
428 ELSIF (nkind = diana.d_f_call) THEN
429 DECLARE args ptnod := diana.as_p_ass(n);
430 BEGIN
431 IF (pidl.ptkin(args) <> diana.ds_param) THEN
432 -- ordinary function call
433 etext(diana.a_name(n));
434 etext(args);
435 ELSE -- operator functions, determine if unary or n-ary
436 DECLARE s pidl.ptseqnd := diana.as_list(args);
437 namenode ptnod := diana.a_name(n);
438 BEGIN
439 IF (pidl.ptslen(s) = 1) THEN -- unary
440 etext(namenode);
441 rv := rv || ' ';
442 etext(pidl.ptgend(s, 0));
443 ELSE exprtext(namenode, rv); listtext(s, rv);
444 END IF;
445 END;
446 END IF;
447 END;
448
449 -- parenthesized expr
450 -- whenever this gets uncommented, we must fully support the
451 -- D_F_CALL case as well (Usha - 6/28/95)
452 ELSIF (nkind = diana.d_parent) THEN
453 rv := rv || '(';
454 etext(diana.a_exp(n));
455 rv := rv || ')';
456
457 -- binary logical operation
458 ELSIF (nkind = diana.d_binary) THEN
459 etext(diana.a_exp1(n));
460 rv := rv || ' ';
461 etext(diana.a_binary(n));
462 rv := rv || ' ';
463 etext(diana.a_exp2(n));
464 ELSIF (nkind = diana.d_and_th) THEN
465 rv := rv || 'and';
466 ELSIF (nkind = diana.d_or_els) THEN
467 rv := rv || 'or';
468
469 ELSIF (nkind = diana.ds_id) THEN -- idList
470 -- listText(diana.as_list(n), ','); causes PL/SQL Check #21037.
471 DECLARE seq pidl.ptseqnd := diana.as_list(n);
472 BEGIN
473 rv := rv || coatname(diana.l_symrep(last_elt(seq)));
474 END;
475
476 ELSIF (nkind = diana.ds_d_ran) THEN
477 DECLARE seq pidl.ptseqnd := diana.as_list(n);
478 x ptnod;
479 BEGIN
480 x := last_elt(seq);
481 etext(diana.a_name(x));
482 END;
483
484 -- declarations
485 ELSIF (nkind = diana.d_var OR nkind = diana.d_consta) THEN
486 -- var and const
487 etext(diana.as_id(n));
488 rv := rv || ' ';
489 IF (nkind = diana.d_consta) THEN
490 rv := rv || 'constant ';
491 END IF;
492 etext(diana.a_type_s(n));
493 IF (diana.a_object(n) IS NOT NULL AND diana.a_object(n) <> 0) THEN
494 rv := rv || ' := ';
495 etext(diana.a_object(n));
496 ELSE assert(nkind <> diana.d_consta);
497 END IF;
498
499 ELSIF (nkind = diana.d_intege) THEN
500 etext(diana.a_range(n));
501 ELSIF (nkind = diana.d_range) THEN
502 IF (diana.a_exp1(n) IS NOT NULL AND diana.a_exp1(n) <> 0) THEN
503 -- in case of array single index;
504 rv := rv || 'range ';
505 etext(diana.a_exp1(n));
506 rv := rv || '..';
507 END IF;
508 etext(diana.a_exp2(n));
509
510 ELSIF (nkind = diana.d_type) THEN -- type declaration
511 rv := rv || 'type ';
512 etext(diana.a_id(n));
513 IF (diana.a_type_s(n) IS NOT NULL AND diana.a_type_s(n) <> 0) THEN
514 rv := rv || ' is ';
515 etext(diana.a_type_s(n));
516 END IF;
517 ELSIF (nkind = diana.d_subtyp) THEN -- subtype declaration
518 rv := rv || 'subtype ';
519 etext(diana.a_id(n));
520 rv := rv || ' is ';
521 etext(diana.a_constd(n));
522 ELSIF (nkind = diana.d_r_) THEN -- record type
523 rv := rv || 'record (';
524 -- listText(diana.as_list(n), ','); causes PL/SQL Check #21037.
525 DECLARE seq pidl.ptseqnd := diana.as_list(n);
529 rv := rv || ')';
526 BEGIN
527 listtext(seq, ', ');
528 END;
530 ELSIF (nkind = diana.d_array) THEN
531 rv := rv || 'table of ';
532 etext(diana.a_name(diana.a_constd(n)));
533 rv := rv || '(';
534 etext(diana.a_constt(diana.a_constd(n)));
535 rv := rv || ') indexed by ';
536 etext(diana.as_dscrt(n));
537 ELSIF (nkind = diana.d_except) THEN
538 etext(diana.as_id(n));
539 rv := rv || ' exception';
540
541 */
542
543 ELSE
544 RAISE e_notv6compat;
545 END IF;
546
547 END IF;
548 END etext;
549
550 BEGIN -- exprText
551 etext(x);
552 END exprtext;
553
554
555 --------------------
556 -- is_v6_type
557 --
558 -- check whether given D_NAME node (from an a_NAME(parm)) names a
559 -- v6-compatible type, e.g., DATE, NUMBER, or CHAR
560 --------------------
561 FUNCTION is_v6_type (typenode ptnod) RETURN BOOLEAN IS
562 typename VARCHAR2(100);
563 percenttype BOOLEAN;
564 BEGIN
565 typename := '';
566 exprtext(typenode, typename);
567 typename := ltrim(rtrim(typename));
568 percenttype := ( length(typename) > 5 AND
569 substr(typename, -5, 5) = '%TYPE' );
570 /* check length as else will get null as substr result */
571 IF (typename = '' OR typename IS NULL) OR
572 NOT ( typename = 'DATE'
573 OR typename = 'NUMBER'
574 OR typename = 'BINARY_INTEGER'
575 OR typename = 'PLS_INTEGER'
576 OR typename = 'CHAR'
577 OR typename = 'VARCHAR2'
578 OR typename = 'VARCHAR'
579 OR typename = 'INTEGER'
580 OR typename = 'BOOLEAN'
581 OR percenttype
582 -- or typename = 'RAW'
583 -- or typename = 'CHARN'
584 -- or typename = 'STRING'
585 -- or typename = 'STRINGN'
586 -- or typename = 'DATEN'
587 -- or typename = 'NUMBERN'
588 -- or typename = 'PLS_INTEGERN'
589 -- or typename = 'NATURAL'
590 -- or typename = 'NATURALN'
591 -- or typename = 'POSITIVE'
592 -- or typename = 'POSITIVEN'
593 -- or typename = 'SIGNTYPE'
594 -- or typename = 'BOOLEANN'
595 -- or typename = 'REAL'
596 -- or typename = 'DECIMAL'
597 -- or typename = 'FLOAT'
598 )
599 THEN
600 RETURN false;
601 ELSE
602 RETURN true;
603 END IF;
604 END is_v6_type;
605
606
607 --------------------
608 -- genProcSpec:
609 -- Append the spec for a top-level node n to sText.
610 -- defValOption controls whether parm default vals should be ignored,
611 -- printed fully or flagged in comments as "DEFAULTED"
612 -- hasDefVal returned true iff parm default vals exist.
613 -- Toplevel name returned in pName. If function, function
614 -- string returned in returnVal.
615 --------------------
616 PROCEDURE genprocspec(n ptnod,
617 defvaloption NUMBER,
618 hasdefval IN OUT BOOLEAN,
619 pname IN OUT VARCHAR2,
620 returnval IN OUT VARCHAR2,
621 flags VARCHAR2,
622 stext IN OUT VARCHAR2) IS
623 nodekind pidl.ptnty;
624 leftchild ptnod;
625 rightchild ptnod;
626 returntypenode ptnod;
627
628 --------------------
629 -- genParmText
630 --------------------
631 PROCEDURE genparmtext(parmseq pidl.ptseqnd) IS
632 -- append text for param list sText
633 parmnum NATURAL;
634 k ptnod;
635 knd pidl.ptnty;
636 BEGIN
637 parmnum := pidl.ptslen(parmseq);
638 IF (parmnum > 0) THEN
639 stext := stext || ' (';
640 FOR i IN 1 .. parmnum LOOP
641 k := pidl.ptgend(parmseq, i-1);
642 assert(k IS NOT NULL);
643 stext := stext || idname(diana.as_id(k)) || ' ';
644 knd := pidl.ptkin(k);
645 IF (knd = diana.d_out) THEN
646 stext := stext || 'out ';
647 ELSIF (knd = diana.d_in_out) THEN
648 stext := stext || 'in out ';
649 ELSE
650 assert(knd = diana.d_in);
651 END IF;
652 exprtext(diana.a_name(k), stext);
653 IF 0 < instr(flags, '6') AND NOT is_v6_type(diana.a_name(k)) THEN
654 RAISE e_notv6compat;
655 END IF;
656
657 k := diana.a_exp_vo(k);
658 IF (k IS NOT NULL AND k <> 0) THEN
659 hasdefval := true;
660 IF defvaloption = defvaloption_full THEN
661 stext := stext || ' := ';
662 exprtext(k, stext);
663 ELSIF defvaloption = defvaloption_default_comment THEN
664 stext := stext || ' /* DEFAULTED */';
665 ELSE
666 assert(defvaloption = defvaloption_ignore);
667 END IF;
668 END IF;
669
670 IF (i < parmnum) THEN
671 stext := stext || ', ';
672 END IF;
673 END LOOP;
674
675 stext := stext || ')';
676 END IF;
677 END genparmtext;
678
679 BEGIN -- genProcSpec
680 -- generate a procedure declaration into sText spec
681
682 returnval := '';
683 assert(n IS NOT NULL);
684 leftchild := diana.a_d_(n);
685 assert(leftchild IS NOT NULL);
686 nodekind := pidl.ptkin(leftchild);
687
688 rightchild := diana.a_header(n);
689 IF (nodekind = diana.di_funct OR nodekind = diana.d_def_op) THEN
690 stext := stext || 'function ';
691 returntypenode := diana.a_name_v(rightchild);
692 exprtext(returntypenode, returnval);
693 -- ?? returnVal := substr(exprText(diana.a_name_v(rightChild)), 1, 511);
694 ELSE
695 stext := stext || 'procedure ';
696 returnval := NULL;
697 assert(nodekind = diana.di_proc);
698 END IF;
699 IF (pname IS NULL) THEN
700 exprtext(leftchild, pname);
701 END IF;
702 stext := stext || pname;
703
704 rightchild := diana.as_p_(rightchild);
705 assert(rightchild IS NOT NULL);
706 genparmtext(diana.as_list(rightchild));
707
708 IF (returnval IS NOT NULL) THEN
709 IF 0 < instr(flags, '6') AND NOT is_v6_type(returntypenode)
710 THEN RAISE e_notv6compat;
711 END IF;
712 stext := stext || ' return ' || returnval;
713 END IF;
714 END genprocspec;
715
716 --------------------
717 -- bool_to_int
718 --------------------
719 FUNCTION bool_to_int(b BOOLEAN) RETURN NUMBER IS
720 BEGIN
721 IF b THEN
722 RETURN 1;
723 ELSIF NOT b THEN
724 RETURN 0;
725 ELSE
726 RETURN NULL;
727 END IF;
728 END bool_to_int;
729
730 --------------------
731 -- int_to_bool
732 --------------------
733 FUNCTION int_to_bool(n NUMBER) RETURN BOOLEAN IS
734 BEGIN
735 IF n IS NULL THEN
736 RETURN NULL;
737 ELSIF n = 1 THEN
738 RETURN true;
739 ELSIF n = 0 THEN
740 RETURN false;
741 ELSE
742 RAISE value_error;
743 END IF;
744 END int_to_bool;
745
746 procedure diu_node_use_statistics (libunit_node IN ptnod,
747 node_count out ub4,
748 node_limit out ub4);
749 pragma interface(c,diu_node_use_statistics);
750
751 procedure diu_attribute_use_statistics (libunit_node IN ptnod,
752 attribute_count out ub4,
753 attribute_limit out ub4);
754 pragma interface(c,diu_attribute_use_statistics);
755
756 -- node_use_statistics: reports libunit's node count and limit
757 --
758 -- Parameters:
759 --
760 -- libunit_node : legal ptnod, as returned by get_diana or get_d
761 -- node_count : how many diana nodes the unit contains
762 -- node_limit : that many diana nodes allowed to allocate
763 --
764 procedure node_use_statistics (libunit_node IN ptnod,
765 node_count out ub4,
766 node_limit out ub4)
767 IS
768 BEGIN
769 diu_node_use_statistics(libunit_node, node_count, node_limit);
770 END node_use_statistics;
771
772 -- attribute_use_statistics: reports libunit's attribute count and limit
773 --
774 -- Parameters:
775 --
776 -- libunit_node : legal ptnod, as returned by get_diana or get_d
777 -- attribute_count : how many diana attributes the unit contains
778 -- attribute_limit : that many diana attributes allowed to allocate
779 --
780 procedure attribute_use_statistics (libunit_node IN ptnod,
781 attribute_count out ub4,
782 attribute_limit out ub4)
783 IS
784 BEGIN
785 diu_attribute_use_statistics
786 (libunit_node, attribute_count, attribute_limit);
787 END attribute_use_statistics;
788
789 end diutil;
[Home] [Help]