home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / glib.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  15.1 KB  |  537 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* glib.c: translation of lib.stl for code generator */
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "libhdr.h"
  14. #include "vars.h"
  15. #include "segment.h"
  16. #include "gvars.h"
  17. #include "ops.h"
  18. #include "type.h"
  19. #include "ifile.h"
  20. #include "segmentprots.h"
  21. #include "gutilprots.h"
  22. #include "setprots.h"
  23. #include "axqrprots.h"
  24. #include "libprots.h"
  25. #include "libfprots.h"
  26. #include "miscprots.h"
  27. #include "glibprots.h"
  28.  
  29. static Set remove_dependent(int);
  30.  
  31. extern int ADA_MIN_INTEGER, ADA_MAX_INTEGER;
  32. extern long ADA_MIN_FIXED, ADA_MAX_FIXED;
  33. extern Tuple segment_map_new(), segment_map_put();
  34. extern Segment segment_new();
  35. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  36.  
  37.  
  38. /*
  39.  * Librarian and binder
  40.  *
  41.  * bind renamed binder to avoid conflict with c library routine of same name 
  42.  */
  43.  
  44.  
  45. Segment main_data_segment()                         /*;main_data_segment*/
  46. {
  47.     /* Initialize the main data segment needed for all programs. This consists
  48.      * mainly of the type templates for the standard types. As the templates
  49.      * are defined, the segment offset of the associated symbols is set
  50.      * correctly. In the SETL version index 81 is the first free position
  51.      * after templates are allocated and is used as the value of the macro
  52.      * relay_tables in the interpreter. We improve on this by setting the first
  53.      * word in the segment to contain the offset of the start of the relay
  54.      * sets.
  55.      */
  56.  
  57.     /* Template pointers */
  58.  
  59.     struct tt_i_range  *tt_for_integer;
  60.     struct tt_e_range  *boolean_tt;
  61.     struct tt_i_range  *positive_tt;
  62.     struct tt_array *string_tt;
  63.     struct tt_i_range  *null_index_tt;
  64.     struct tt_s_array  *null_string_tt;
  65.     struct tt_e_range  *character_tt;
  66.     struct tt_task *main_task_type_tt;
  67.     struct tt_i_range  *natural_tt;
  68.     struct tt_fx_range *duration_tt;
  69.     struct tt_fx_range *integer_fixed_tt;
  70.     struct tt_fl_range *float_tt;
  71.  
  72.     int    *ds, di, i, off_for_main_task_body;
  73.     Segment seg;
  74.  
  75.     /* SETL text used to define initial data segment:
  76.      * DATA_SEGMENT =
  77.      *    [tt_access, 2]                  1 : $ACCESS
  78.      *    + [tt_i_range, 1, -(2**30)+1, 2**30-1]     3 : integer
  79.      *    + [tt_enum, 1, 0, 1,                  7 : boolean
  80.      *        5, 70, 65, 76, 83, 69,
  81.      *        4, 84, 82, 85, 69]
  82.      *    + [tt_i_range, 1, 1, 2**30-1]          22 : positive
  83.      *    + [tt_u_array, 2**30-1, 1, 1, 23, 1, 22]      26 : string
  84.      *    + [tt_i_range, 1, 1, 0]              33 : null index
  85.      *    + [tt_s_array, 0, 1, 2, 1, 0]              37 : null string
  86.      *    + [tt_enum, 1, 0, 127]              43 : character
  87.      *    + [tt_task, 1, 6, 1, 54, 0, 0]              47 : main_task_type
  88.      *    + [main_cs, 0, 0]                  54 : main_task_body
  89.      *    + [tt_i_range, 1, 0, 2**30-1]          57 : natural
  90.      *    + [tt_fixed, 1, -3, -3, -(2**30)+1,
  91.      *                2**30-1]          61 : duration
  92.      *    + [tt_fixed, 1, 0, 0, -(2**30)+1, 2**30-1]   67 : integer_fixed
  93.      *    + [tt_f_range, 1, F_TO_I(ada_min_real),
  94.      *            F_TO_I(ada_max_real)]     73 : FLOAT
  95.      *    + [tt_i_range, 1, -(2**15)+1, 2**15-1]     77 : SHORT_INTEGER
  96.      *                          81 : relay sets
  97.      *    [tt_access, 2]                 : $ACCESS
  98.      */
  99.  
  100.     ds = (int *) ecalloct(150, sizeof(int), "main-data-segment");
  101.     /* di[0] used to store offset of relay tables(see below) */
  102.     di = 1;            /* initial offset */
  103.  
  104.     S_OFFSET(symbol_daccess) = di;
  105.  
  106.     /* first two words are not template */
  107.     ds[di++] = TT_ACCESS;
  108.     ds[di++] = 2;
  109.  
  110.     /* tt_i_range, 1, -(2**30)+1, 2**30-1]    : integer */
  111.  
  112.     S_OFFSET(symbol_integer) = di;
  113.     S_OFFSET(symbol_universal_integer) = di;
  114.  
  115.     tt_for_integer = I_RANGE((ds + di));
  116.     tt_for_integer->ttype = TT_I_RANGE;
  117.     tt_for_integer->object_size = 1;
  118.     tt_for_integer->ilow = ADA_MIN_INTEGER;/* check this and next line */
  119.     tt_for_integer->ihigh = ADA_MAX_INTEGER;
  120.     S_OFFSET(symbol_integer) = di;
  121.     di += WORDS_I_RANGE;
  122.  
  123.     /* [tt_enum, 1, 0, 1,            : boolean * 5, 70, 65, 76, 83, 69, *
  124.     4, 84, 82, 85, 69] */
  125.  
  126.     S_OFFSET(symbol_boolean) = di;
  127.  
  128.     boolean_tt = E_RANGE((ds + di));
  129.     boolean_tt->ttype = TT_ENUM;
  130.     boolean_tt->object_size = 1;
  131.     boolean_tt->elow = 0;
  132.     boolean_tt->ehigh = 1;
  133.     di += WORDS_E_RANGE;
  134.     /* put enumeration values */
  135.     ds[di++] = 5;        /* length of FALSE */
  136.     ds[di++] = 'F';
  137.     ds[di++] = 'A';
  138.     ds[di++] = 'L';
  139.     ds[di++] = 'S';
  140.     ds[di++] = 'E';
  141.     ds[di++] = 4;        /* length of TRUE */
  142.     ds[di++] = 'T';
  143.     ds[di++] = 'R';
  144.     ds[di++] = 'U';
  145.     ds[di++] = 'E';
  146.  
  147.     /* [tt_i_range, 1, 1, 2**30-1]          : positive */
  148.  
  149.     S_OFFSET(symbol_positive) = di;
  150.  
  151.     positive_tt = I_RANGE((ds + di));
  152.     positive_tt->ttype = TT_I_RANGE;
  153.     positive_tt->object_size = 1;
  154.     positive_tt->ilow = 1;
  155.     positive_tt->ihigh = ADA_MAX_INTEGER;/* check this */
  156.     di += WORDS_I_RANGE;
  157.  
  158.     /* [tt_u_array, 2**30-1, 1, 1, 23, 1, 22]     : string */
  159.  
  160.     S_OFFSET(symbol_string_type) = di;
  161.     S_OFFSET(symbol_string) = di;
  162.  
  163.     string_tt = ARRAY((di + ds));
  164.     string_tt->ttype = TT_U_ARRAY;
  165.     string_tt->object_size = ADA_MAX_INTEGER;
  166.     string_tt->dim = 1;
  167.     string_tt->component_base = 1;
  168.     /* string_tt->component_offset is set below when character defined */
  169.     string_tt->index1_base = 1;
  170.     string_tt->index1_offset = S_OFFSET(symbol_positive);
  171.     di += WORDS_ARRAY;
  172.  
  173.     /* [tt_i_range, 1, 1, 0]              : null index */
  174.  
  175.     null_index_tt = I_RANGE((ds + di));
  176.     null_index_tt->ttype = TT_I_RANGE;
  177.     null_index_tt->object_size = 1;
  178.     null_index_tt->ilow = 1;
  179.     null_index_tt->ihigh = 0;
  180.     di += WORDS_I_RANGE;
  181.  
  182.     /* [tt_s_array, 0, 1, 2, 1, 0]              : null string */
  183.  
  184.     null_string_tt = S_ARRAY((di + ds));
  185.     null_string_tt->ttype = TT_S_ARRAY;
  186.     null_string_tt->object_size = 0;
  187.     ;
  188.     null_string_tt->component_size = 1;
  189.     null_string_tt->index_size = 2;
  190.     null_string_tt->salow = 1;
  191.     null_string_tt->sahigh = 0;
  192.     di += WORDS_S_ARRAY;
  193.  
  194.     /* [tt_enum, 1, 0, 127]              : character */
  195.  
  196.     S_OFFSET(symbol_character) = di;
  197.     S_OFFSET(symbol_character_type) = di;
  198.  
  199.     /* Can set component_offset for string now */
  200.     string_tt->component_offset = di;
  201.  
  202.     character_tt = E_RANGE((di + ds));
  203.     character_tt->ttype = TT_ENUM;
  204.     character_tt->object_size = 1;
  205.     ;
  206.     character_tt->elow = 0;
  207.     character_tt->ehigh = 127;
  208.     di += WORDS_E_RANGE;
  209.     ds[di++] = -1;              /* no list of images */
  210.  
  211.     /* [tt_task, 1, 6, 1, 54, 0, 0]              : main_task_type */
  212.  
  213.     S_OFFSET(symbol_main_task_type) = di;
  214.  
  215.     main_task_type_tt = TASK((di + ds));
  216.     main_task_type_tt->ttype = TT_TASK;
  217.     main_task_type_tt->object_size = 1;
  218.     main_task_type_tt->priority = MAX_PRIO-1; /* TBSL: priority of main */
  219.     main_task_type_tt->body_base = 1;/* segment number */
  220.     /* body_off filled in later */
  221.     main_task_type_tt->collection_size = 1000;
  222.     main_task_type_tt->collection_avail = 1000;
  223.     main_task_type_tt->nb_entries = 0;
  224.     main_task_type_tt->nb_families = 0;
  225.     di += WORDS_TASK;
  226.  
  227.     /* [main_cs, 0, 0]                  : main_task_body */
  228.  
  229.     off_for_main_task_body = di;
  230.     ds[di++] = MAIN_CS;
  231.     ds[di++] = 0;
  232.     ds[di++] = 0;
  233.     main_task_type_tt->body_off = off_for_main_task_body;
  234.  
  235.     /* [tt_i_range, 1, 0, 2**30-1]          : natural */
  236.  
  237.     S_OFFSET(symbol_natural) = di;
  238.  
  239.     natural_tt = I_RANGE((ds + di));
  240.     natural_tt->ttype = TT_I_RANGE;
  241.     natural_tt->object_size = 1;
  242.     ;
  243.     natural_tt->ilow = 0;
  244.     natural_tt->ihigh = ADA_MAX_INTEGER;/* check this */
  245.     di += WORDS_I_RANGE;
  246.  
  247.     /* [tt_fixed, 1, -3, -3, -(2**30)+1, 2**30-1]         : duration */
  248.  
  249.     S_OFFSET(symbol_duration) = di;
  250.  
  251.     duration_tt = FX_RANGE((ds + di));
  252.     duration_tt->ttype = TT_FX_RANGE;
  253.     duration_tt->object_size = 1;
  254.     duration_tt->small_exp_2 = -3;
  255.     duration_tt->small_exp_5 = -3;
  256.     duration_tt->fxlow = 0 ;
  257.     duration_tt->fxhigh = 86400000L;
  258.     di += WORDS_FX_RANGE;
  259.  
  260.     /* [tt_fixed, 1, 0, 0, -(2**30)+1, 2**30-1]   : integer_fixed */
  261.  
  262.     S_OFFSET(symbol_dfixed) = di;
  263.  
  264.     integer_fixed_tt = FX_RANGE((ds + di));
  265.     integer_fixed_tt->ttype = TT_FX_RANGE ;
  266.     integer_fixed_tt->object_size = 1 ;
  267.     integer_fixed_tt->small_exp_2 = 0;
  268.     integer_fixed_tt->small_exp_5 = 0;
  269.     integer_fixed_tt->fxlow = -ADA_MAX_FIXED;
  270.     integer_fixed_tt->fxhigh = ADA_MAX_FIXED;
  271.     di += WORDS_FX_RANGE;
  272.  
  273.     /* [tt_f_range, 1, F_TO_I(ada_min_real), F_TO_I(ada_max_real)]   : FLOAT */
  274.  
  275.     S_OFFSET(symbol_float) = di;
  276.     S_OFFSET(symbol_universal_real) = di;
  277.  
  278.     float_tt = FL_RANGE((ds + di));
  279.     float_tt->ttype = TT_FL_RANGE;
  280.     float_tt->object_size = sizeof(long)/sizeof(int) ;
  281.     float_tt->fllow = ADA_MIN_REAL;
  282.     float_tt->flhigh = ADA_MAX_REAL;
  283.     di += WORDS_FL_RANGE;
  284.  
  285. #ifdef TBSL
  286.     -- short integer not supported yet
  287.         + [tt_i_range, 1, -(2**15)+1, 2**15-1]    /* 77 : SHORT_INTEGER */
  288.     S_OFFSET(symbol_short_integer) = di;
  289. #endif
  290.     /* The interpreter needs to know where the relay sets. We store this
  291.      * offset in the first word of the data segment
  292.      */
  293.     ds[0] = di;            /* 81? : relay sets */
  294.  
  295.     seg = segment_new(SEGMENT_KIND_DATA, di);
  296.     for (i = 0; i < di; i++) {
  297.         segment_put_int(seg, ds[i]);
  298.     }
  299.     /* ds dead now that contents copied into segment */
  300.     efreet((char *) ds, "main-data-segment");
  301.     return seg;
  302. }
  303.  
  304. Set precedes_map_get(char *name)                        /*;precedes_map_get*/
  305. {
  306.     int        unum, i, n;
  307.     unum = unit_numbered(name);
  308.     n = tup_size(PRECEDES_MAP);
  309.     for (i=1; i<=n; i+=2) {
  310.         if (PRECEDES_MAP[i] == (char *)unum)
  311.             return (Set) PRECEDES_MAP[i+1];
  312.     }
  313.     return set_new(0);
  314. }
  315.  
  316. void precedes_map_put(char *name, Set nset)                /*;precedes_map_put*/
  317. {
  318.     int        unum, i, n;
  319.     unum = unit_numbered(name);
  320.     n = tup_size(PRECEDES_MAP);
  321.     for (i=1; i<=n; i+=2) {
  322.         if (PRECEDES_MAP[i] == (char *) unum) {
  323.             PRECEDES_MAP[i+1] = (char *) nset;
  324.             return;
  325.         }
  326.     }
  327.     PRECEDES_MAP = tup_exp(PRECEDES_MAP, n+2);
  328.     PRECEDES_MAP[n+1] = (char *) unum;
  329.     PRECEDES_MAP[n+2] = (char *) nset;
  330. }
  331.  
  332. Tuple stubs(char *lib_name)                                        /*;stubs*/
  333. {
  334.     char    *name;
  335.     Fortup    ft1;
  336.     Tuple    stublist;
  337.     int        parent;
  338.     stublist = tup_new(0);
  339.     if (!streq(unit_name_type(lib_name), "sp")) {
  340.         /* stublist = {n : n in domain STUB_ENV | n(3..) = lib_name(2..)}; */
  341.         parent = unit_numbered(lib_name);
  342.         FORTUP(name=(char *), lib_stub, ft1);
  343.             if (stub_parent_get(name) == parent)
  344.                 stublist = tup_with(stublist, name);
  345.         ENDFORTUP(ft1);
  346.     }
  347.     return stublist;
  348. }
  349.  
  350. Set remove_same_name(char *name)                /*;remove_same_name */
  351. {
  352.     /*
  353.      * remove references in library maps to previously compiled units with
  354.      * the same name, except for specs if name is the corresponding body.
  355.      * returns the set of deleted names.
  356.      */
  357.  
  358.     Set        same_name, dependent, obsolete;
  359.     char    *to_keep, *unam;
  360.     int        i, unum;
  361.     Forset    fs1;
  362.     Fortup    ft1;
  363.  
  364.     same_name = set_new(0);
  365.     if (streq(unit_name_type(name), "bo"))
  366.         to_keep = "sp";
  367.     else if (streq(unit_name_type(name), "su"))
  368.         to_keep = "ss";
  369.     else
  370.         to_keep = "";
  371.  
  372.     /* loop forall u_data = LIB_UNIT(unam) | unam(2..) = name(2..) and
  373.      *            unam(1)  != to_keep
  374.      * do
  375.      *  same_name with:= unam;
  376.      * end loop;
  377.      */
  378.  
  379.     for (i = 1; i <= unit_numbers; i++) {
  380.         unam = pUnits[i]->libUnit;
  381.         if (streq(unit_name_names(unam), unit_name_names(name))
  382.           && !streq(unit_name_type(unam), to_keep)) {
  383.             same_name = set_with(same_name, (char *) unit_numbered(unam));
  384.         }
  385.     }
  386.  
  387.     same_name = set_with(same_name, (char *) unit_numbered(name));
  388.     dependent = set_new(0);
  389.  
  390.     /* Remove all units which depend on either units with the same identifier
  391.      * as "name" or that depend on "name" itself.
  392.      */
  393.     FORSET(unum=(int), same_name, fs1);
  394.         dependent = set_union(dependent, remove_dependent(unum));
  395.     ENDFORSET(fs1);
  396.  
  397.     /* remove "name" from the set of units that have the same id */
  398.     same_name = set_less(same_name, (char *) unit_numbered(name));
  399.  
  400.     obsolete = set_union(same_name, dependent);
  401.  
  402.     FORTUP(unam=(char *), lib_stub, ft1);
  403.         if (set_mem((char *) stub_parent_get(unam), obsolete))
  404.             lib_stub_put(unam, (char *)0);
  405.     ENDFORTUP(ft1);
  406.  
  407.     return obsolete;
  408. }
  409.  
  410. static Set remove_dependent(int unit_num)                /*;remove_dependent */
  411. {
  412.     /*
  413.      * remove references in library maps to units depending directly or
  414.      * indirectly on the give unit.
  415.      * returns the set of deleted names.
  416.      */
  417.  
  418.     char    *mname, *name, *unam;
  419.     int        i, unum, nameFound;
  420.     Set        dependent, new_dep, precedes;
  421.     Forset    fs1;
  422.  
  423.     name = pUnits[unit_num]->name;
  424.     nameFound = FALSE;
  425.     mname = strjoin("ss", unit_name_names(name));
  426.     for (i = 1; i <= unit_numbers; i++) {
  427.         if (streq(mname, pUnits[i]->libUnit)) {
  428.             nameFound = TRUE;
  429.             break; }
  430.     }
  431.     dependent = set_new(0);
  432.     if (streq(unit_name_type(name), "bo") || (streq(unit_name_type(name), "su")
  433.       && nameFound)) {
  434.         /* Package body and subprog body with separate spec. Only subunits
  435.          * may depend on such things, plus units naming them in pragma 
  436.          * elaborate. Only subunits must be deleted. 
  437.          */
  438.  
  439.         /* dependent= {unam: unam in domain LIB_UNIT
  440.          *        | IS_SUBUNIT(unam) and name in precedes{unam}  };
  441.          */
  442.         for (i = 1; i <= unit_numbers; i++) {
  443.             unam = pUnits[i]->libUnit;
  444.             if (is_subunit(unam)) {
  445.                 precedes = precedes_map_get(unam);
  446.                 if (set_mem((char *) unit_numbered(name), precedes))
  447.                     dependent = set_with(dependent,(char *)unit_numbered(unam));
  448.             }
  449.         }
  450.     }
  451.     else {
  452.         /* dependent= {unam: unam in domain LIB_UNIT
  453.          *         | name in precedes{unam}};
  454.          */
  455.         for (i = 1; i <= unit_numbers; i++) {
  456.             unam = pUnits[i]->libUnit;
  457.             precedes = precedes_map_get(unam);
  458.             if (set_mem((char *) unit_numbered(name), precedes))
  459.                 dependent = set_with(dependent, (char *) unit_numbered(unam));
  460.         }
  461.     }
  462.     new_dep = set_new(0);
  463.  
  464.     FORSET(unum=(int), dependent, fs1);
  465.         new_dep = set_union(new_dep, remove_dependent(unum));
  466.     ENDFORSET(fs1);
  467.  
  468.     return set_union(dependent, new_dep);
  469. }
  470.  
  471. int lib_package_with_tasks(Symbol unit_unam)        /*;lib_package_with_tasks */
  472. {
  473.     Tuple   tup;
  474.     tup = (Tuple) MISC(unit_unam);
  475.     return ((int)tup[1]);
  476. }
  477.  
  478. #ifdef DEBUG
  479. Tuple read_predef_axq(Tuple axq_needed)                    /*;read_predef_axq*/
  480. {
  481.     IFILE *axq_file;
  482.     Segment    newseg, fakseg;
  483.     int        snum, nsegs;
  484.     char    *funame;
  485.     long    genpos, rec;
  486.     int     name_num, n, skip_it;
  487.     Tuple       predef_data_segments;
  488.     Tuple       predef_code_segments;
  489.     Tuple       data_n_code;
  490.     Fortup    ft1;
  491.  
  492.  
  493.     fakseg = segment_new(SEGMENT_KIND_CODE, 0);
  494.     segment_put_byte(fakseg, I_LEAVE_BLOCK);
  495.     segment_put_byte(fakseg, I_RAISE);
  496.     segment_put_byte(fakseg, I_ENTER_BLOCK);
  497.     segment_put_byte(fakseg, I_LEAVE_BLOCK);
  498.     segment_put_int (fakseg, 0); /* size of local objects */
  499.  
  500.     predef_data_segments = tup_new(0);
  501.     predef_code_segments = tup_new(0);
  502.  
  503.     axq_file = ifopen(PREDEFNAME, ".axq", "r", "a", iot_ais_r, 0);
  504.     for (rec=read_init(axq_file); rec != 0; rec=read_next(axq_file, rec)) {
  505.         funame = getstr(axq_file, "axq-unit-name");
  506.         name_num = getnum(axq_file, "axq-unit-number");
  507.         skip_it = TRUE;
  508.         FORTUP(n=(int), axq_needed, ft1)
  509.             if (n == name_num) {
  510.                 skip_it = FALSE;
  511.                 break;
  512.             }
  513.         ENDFORTUP(ft1)
  514.         if (skip_it) continue;
  515.         genpos = getlong(axq_file, "axq-gen-pos");
  516.         /* position to start of slots info */
  517.         ifseek(axq_file, "gen-pos", genpos, 0);
  518.         /* data segments */
  519.         nsegs = getnum(axq_file, "number-segments");
  520.         if(nsegs != 1) chaos("read_predef_axq data segment number invalid");
  521.         snum = getnum(axq_file, "axq-segment-num");
  522.         predef_data_segments = tup_with(predef_data_segments, (char *) snum);
  523.         newseg = segment_read(axq_file);
  524.         DATA_SEGMENT_MAP = segment_map_put(DATA_SEGMENT_MAP, snum, newseg);
  525.         /* fake code segment */
  526.         snum = *((int *)newseg->seg_data);
  527.         predef_code_segments = tup_with(predef_code_segments, (char *) snum);
  528.         CODE_SEGMENT_MAP = segment_map_put(CODE_SEGMENT_MAP, snum, fakseg);
  529.     }
  530.     ifclose(axq_file);
  531.     data_n_code = tup_new(2);
  532.     data_n_code[1] = (char *)predef_data_segments;
  533.     data_n_code[2] = (char *)predef_code_segments;
  534.     return data_n_code;
  535. }
  536. #endif
  537.