prop-src/datatype.pcc

   1 /////////////////////////////////////////////////////////////////////////////
   2 //
   3 //  This file implements the DatatypeClass
   4 //
   5 //////////////////////////////////////////////////////////////////////////////
   6 #include <AD/strings/quark.h>
   7 #include "datatype.ph"
   8 #include "ast.ph"
   9 #include "ir.ph"
  10 #include "type.h"
  11 #include "options.h"
  12 #include "list.h"
  13 #include "datagen.h"
  14
  15 //////////////////////////////////////////////////////////////////////////////
  16 //
  17 //  Constructor for DatatypeClass
  18 //
  19 //////////////////////////////////////////////////////////////////////////////
  20 DatatypeClass::DatatypeClass
  21    (CLASS_TYPE my_class_type,
  22     Id cid, Id id, TyVars p, Inherits i, TyQual q, Decls d, Cons c,
  23     DatatypeHierarchy * r)
  24    : ClassDefinition(my_class_type,id,p,i,q,d),
  25      constructor_name(cid), cons(c), root(r),
  26      generating_list_special_forms(false),
  27      cons_arg_ty(NOty), has_destructor(false)
  28    {
  29       is_const = (qualifiers & QUALconst) ? "const " : "";
  30       is_list  = is_list_constructor(constructor_name);
  31       is_array = is_array_constructor(constructor_name);
  32    }
  33
  34 DatatypeClass::~DatatypeClass() {}
  35
  36 //////////////////////////////////////////////////////////////////////////////
  37 //
  38 //  Method to update the qualifiers and other
  39 //
  40 //////////////////////////////////////////////////////////////////////////////
  41 void DatatypeHierarchy::get_info()
  42 {
  43    if (got_info) return;
  44
  45    got_info = true;
  46
  47 /*
  48    match (lookup_ty(datatype_name))
  49    {  DATATYPEty({ qualifiers = q, body = b, unit, arg, terms ... },_):
  50       {  qualifiers = q;
  51          class_body = b;
  52          for (int i = 0; i < number_of_subclasses; i++)
  53          {  match (subclasses[i]->cons)
  54             {  ONEcons { inherit, qual, body ... }:
  55                {  // subclasses[i]->inherited_classes = inherit;
  56                   subclasses[i]->qualifiers |= qual;
  57                   subclasses[i]->class_body = body;
  58                }
  59             |  _: // skip
  60             }
  61          }
  62       }
  63    |  _: // skip
  64    }
  65 */
  66
  67
  68    //
  69    //  Construct the inheritance list and fix it up if necessary
  70    //
  71    build_inheritance_list();
  72
  73    //
  74    //  Use inline methods if we are not in space saving mode
  75    //  or if the user specificately specified the inline qualifier
  76    //
  77    Bool must_inline     = (qualifiers & QUALinline);
  78    Bool must_not_inline = (qualifiers & QUALextern);
  79    if (must_inline && must_not_inline)
  80    {  error("%Ldatatype %s%V cannot be inline and external at the same time",
  81             datatype_name, parameters
  82            );
  83    }
  84    if (must_inline)          inline_methods = true;
  85    else if (must_not_inline) inline_methods = false;
  86    else                      inline_methods = (! options.save_space);
  87
  88    //
  89    //  Use a variant tag if we have subclasses in our hierarchy
  90    //  and if the tag is not embedded into the pointer representation
  91    //
  92    has_variant_tag = ((optimizations & OPTtagless) == 0);
  93
  94    has_destructor = (qualifiers & QUALvirtualdestr) || (cons && is_array);
  95 }
  96
  97 //////////////////////////////////////////////////////////////////////////////
  98 //
  99 //  Constructor for DatatypeHierarchy
 100 //
 101 //////////////////////////////////////////////////////////////////////////////
 102 DatatypeHierarchy::DatatypeHierarchy
 103     (Id id, TyVars p, Inherits i, TyQual q, TermDefs t, Decls d)
 104     : DatatypeClass(DATATYPE_CLASS,id,#"a_" + id,p,i,q,d,NOcons,this),
 105       datatype_name(id), term_defs(t), subclasses(0),
 106       number_of_subclasses(0), datatype_ty(NOty)
 107     {
 108        unit_constructors = 0;
 109        arg_constructors  = 0;
 110        constructor_terms = 0;
 111        use_persist_base  = false;
 112        use_gc_base       = false;
 113        got_info          = false;
 114
 115        //
 116        //  Build the class hierarchy
 117        //
 118        build_class_hierarchy();
 119
 120     }
 121
 122 DatatypeHierarchy::~DatatypeHierarchy()
 123 {
 124    delete [] subclasses;
 125 }
 126
 127 //////////////////////////////////////////////////////////////////////////////
 128 //
 129 //  Method to build the class hierarchy given a datatype.
 130 //  We'll create a DatatypeClass object for each subclass.
 131 //
 132 //////////////////////////////////////////////////////////////////////////////
 133 void DatatypeHierarchy::build_class_hierarchy()
 134 {
 135    // don't bother building the class hierarchy for views
 136    if (is_view()) return;
 137
 138    // construct class hierarchy
 139    match (lookup_ty(datatype_name))
 140    {  mytype as DATATYPEty({ unit, arg, opt, terms, hierarchy ... }, _):
 141       {  arity = unit + arg;
 142          unit_constructors = unit;
 143          arg_constructors  = arg;
 144          constructor_terms = terms;
 145          optimizations     = opt;
 146          datatype_ty       = mytype;
 147          hierarchy         = this;
 148          if (arg > 0) // build class hierarchy only if we have more than
 149                       // one variants
 150          {  if (opt & OPTsubclassless) // no subclass
 151             {  number_of_subclasses = 0;
 152                for (int i = 0; i < arity; i++)
 153                {  if (terms[i]->ty != NOty)
 154                   {  cons = terms[i];
 155                      constructor_name = cons->name;
 156                      is_list  = is_list_constructor(constructor_name);
 157                      is_array = is_array_constructor(constructor_name);
 158                      class_body = append(class_body, terms[i]->body);
 159                   }
 160                }
 161             }
 162             else // use subclass
 163             {  number_of_subclasses = arg;
 164                subclasses = new DatatypeClass * [number_of_subclasses];
 165                for (int i = 0, j = 0; i < arity; i++)
 166                {  if (terms[i]->ty != NOty)
 167                   {  subclasses[j++] = build_one_subclass(terms[i]);
 168                   }
 169                }
 170             }
 171          }
 172       }
 173    |  _: // skip
 174    }
 175 }
 176
 177 //////////////////////////////////////////////////////////////////////////////
 178 //
 179 //  Method to build one subclass in the hierarchy.
 180 //
 181 //////////////////////////////////////////////////////////////////////////////
 182 DatatypeClass * DatatypeHierarchy::build_one_subclass(Cons cons)
 183 {  match (cons)
 184    {  ONEcons { name, ty, location, inherit, body, qual, class_def ... }:
 185       {  return class_def = new DatatypeClass(
 186              DATATYPE_SUBCLASS,
 187              name,
 188              Quark(mangle(datatype_name),"_",mangle(name)),
 189              parameters,
 190              add_inherit(class_name,parameters,inherit),
 191              qual,
 192              body,
 193              cons,
 194              this);
 195       }
 196    |  _:   { return 0; }
 197    }
 198 }
 199
 200 //////////////////////////////////////////////////////////////////////////////
 201 //
 202 //  Method to build the inheritance list of the class hierachy.
 203 //
 204 //////////////////////////////////////////////////////////////////////////////
 205 void DatatypeHierarchy::build_inheritance_list()
 206 {
 207    if (qualifiers & QUALrelation)    append_base_class("Fact");
 208    if (qualifiers & QUALrewritable)  append_base_class("TermObj");
 209    if (qualifiers & QUALpersistent)  append_base_class("PObject");
 210
 211    if (qualifiers & QUALcollectable)
 212    {  // Make sure we are only inheriting from one collectable object
 213       // Make sure virtual inheritance is not used.
 214       // Make sure that the collectable object is the first base class.
 215
 216       int pos       = 0;
 217       int count     = 0;
 218       for_each (Inherit, inh, inherited_classes)
 219       {  if((inh->qualifiers & QUALcollectable) || is_gc_ty(inh->super_class))
 220          {  count++;
 221             if (pos != 0)
 222             {  msg("%!%wcollectable object %T must be first base class\n",
 223                   inh->loc(), inh->super_class);
 224             }
 225          }
 226          if (inh->qualifiers & QUALvirtual)
 227          {  msg("%!%wvirtual inheritance of %T may fail"
 228                 " with garbage collection\n",
 229                 inh->loc(), inh->super_class);
 230          }
 231          pos++;
 232       }
 233       if (count >= 2)
 234       {  error("%Linheritance of multiple collectable object will fail\n");
 235       }
 236       if (count == 0)
 237       {  add_base_class("GCObject");
 238       }
 239    }
 240 }
 241
 242 //////////////////////////////////////////////////////////////////////////////
 243 //
 244 // Method to generate a class constructor
 245 //
 246 //////////////////////////////////////////////////////////////////////////////
 247 void DatatypeClass::gen_class_constructor(CodeGen& C, Tys tys, DefKind k)
 248 {
 249    ClassDefinition::gen_class_constructor(C,tys,k);
 250
 251    if (is_list)
 252    {  generating_list_special_forms = true;
 253       ClassDefinition::gen_class_constructor(C,tys,k);
 254       generating_list_special_forms = false;
 255    }
 256 }
 257
 258 //////////////////////////////////////////////////////////////////////////////
 259 //
 260 //  Method to generate the constructor parameters.
 261 //
 262 //////////////////////////////////////////////////////////////////////////////
 263 void DatatypeClass::gen_class_constructor_parameters
 264    (CodeGen& C, Tys tys, DefKind k)
 265 {
 266    Ty arg_ty = cons_arg_ty;
 267    match (deref(arg_ty))
 268    {  TUPLEty #[a,b] | generating_list_special_forms:
 269       { arg_ty = mktuplety(#[a]); }
 270    |  _: // skip
 271    }
 272    Parameter param;
 273    switch (k)
 274    {  case EXTERNAL_IMPLEMENTATION:
 275       case EXTERNAL_INSTANTIATION:
 276          param = TYsimpleformal; break;
 277       default:
 278          param = TYformal; break;
 279    }
 280    C.pr("%b", arg_ty, cons->name, param);
 281 }
 282
 283 //////////////////////////////////////////////////////////////////////////////
 284 //
 285 //  Method to generate the constructor initializers.
 286 //
 287 //////////////////////////////////////////////////////////////////////////////
 288 void DatatypeClass::gen_class_constructor_initializers
 289    (CodeGen& C, Tys tys, DefKind k)
 290 {
 291    match (cons)
 292    {  ONEcons { ty, cons_ty, name ... }:
 293       {  Id colon = " : ";
 294          Id comma = "";
 295          C.pr("%^");
 296
 297          // First generate the tag initializer
 298          if (root->has_variant_tag)
 299          {  if (k == EXTERNAL_INSTANTIATION)
 300                C.pr(" : %s%P(tag_%S)",
 301                    root->class_name, tys, constructor_name);
 302             else
 303                C.pr(" : %s%V(tag_%S)",
 304                    root->class_name, parameters, constructor_name);
 305             colon = ""; comma = ", ";
 306          }
 307
 308          // Now generate the initializers for the arguments
 309          gen_constructor_initializers(C,tys,k,cons_arg_ty,colon,comma);
 310       }
 311    |  _: // skip
 312    }
 313 }
 314
 315 //////////////////////////////////////////////////////////////////////////////
 316 //
 317 //  Method to generate the constructor initializers.
 318 //
 319 //////////////////////////////////////////////////////////////////////////////
 320 void DatatypeClass::gen_constructor_initializers
 321    (CodeGen& C, Tys tys, DefKind k, Ty ty, Id colon, Id comma)
 322 {
 323    if (is_array)
 324    {  C.pr("%s%slen_(x__len_)", colon, comma);
 325       colon = ""; comma = ", ";
 326       ty = mkarrayty(ty,IDexp("len_"));
 327    }
 328
 329    match (deref(ty))
 330    {  TUPLEty #[]: // skip
 331    |  TUPLEty ts: // tuple arguments
 332       {  int i = 1;
 333          for_each(Ty, t, ts)
 334          {  if (generating_list_special_forms && i == 2)
 335             {  if (k == EXTERNAL_INSTANTIATION)
 336                   C.pr("%s%s_%i((%s%P *)0)", colon, comma,
 337                        i, root->class_name, tys, i);
 338                else
 339                   C.pr("%s%s_%i((%s%V *)0)", colon, comma,
 340                        i, root->class_name, parameters, i);
 341                colon = ""; comma = ", ";
 342             }
 343             else
 344             {  if (! is_array_ty(t))
 345                {  C.pr("%s%s_%i(x_%i)", colon, comma, i, i);
 346                   colon = ""; comma = ", ";
 347                }
 348             }
 349             i++;
 350          }
 351       }
 352    |  RECORDty (labels,_,tys): // record arguments
 353       {  Ids l; Tys t;
 354          for (l = labels, t = tys; l && t; l = l->#2, t = t->#2) {
 355             if (! is_array_ty(t->#1))
 356             {  C.pr("%s%s%s(x_%s)", colon, comma, l->#1, l->#1);
 357                colon = ""; comma = ", ";
 358             }
 359          }
 360       }
 361    |  ty:  // single argument
 362       {  if (! is_array_ty(ty))
 363          {  C.pr("%s%s%S(x_%S)",
 364                  colon, comma, constructor_name, constructor_name);
 365                  colon = ""; comma = ", ";
 366          }
 367       }
 368    }
 369 }
 370
 371 //////////////////////////////////////////////////////////////////////////////
 372 //
 373 //  Methods to generate body of a constructor
 374 //
 375 //////////////////////////////////////////////////////////////////////////////
 376 void DatatypeClass::gen_class_constructor_body(CodeGen& C, Tys tys, DefKind k)
 377 {
 378    if (cons == NOcons) return;
 379
 380    Ty ty = cons_arg_ty;
 381    if (is_array)
 382    {  ty = mkarrayty(ty,IDexp("len_"));
 383    }
 384
 385    // Now generate the initializers for array arguments
 386    match (deref(ty))
 387    {  TUPLEty #[]: // skip
 388    |  TUPLEty ts: // tuple arguments
 389       {  int i = 1;
 390          for_each(Ty, t, ts)
 391          {  gen_array_initializer(C,tys,k,index_of(i),t,"x");
 392             i++;
 393          }
 394       }
 395    |  RECORDty (labels,_,tys):
 396       {  Ids ls; Tys ts;
 397          for(ls = labels, ts = tys; ls && ts; ls = ls->#2, ts = ts->#2)
 398          {  gen_array_initializer(C,tys,k,ls->#1,ts->#1,"x_");
 399          }
 400       }
 401    |  t:  { gen_array_initializer(C,tys,k,mangle(cons->name),t,"x_"); }
 402    }
 403 }
 404
 405 //////////////////////////////////////////////////////////////////////////////
 406 //
 407 //  Methods to generate body of a constructor
 408 //
 409 //////////////////////////////////////////////////////////////////////////////
 410 void DatatypeClass::gen_array_initializer
 411    (CodeGen& C, Tys tys, DefKind k, Id exp, Ty ty, Id prefix)
 412 {  match (deref(ty))
 413    {  ARRAYty(elem_ty,bound):
 414       {  C.pr("%^{%+"
 415               "%^for (int i__ = 0; i__ < (%e); i__++)"
 416               "%^{%+",
 417               bound);
 418          if (is_array)
 419          {  C.pr("%^typedef %t ELEMENT_TYPE__;"
 420                  "%^new (%S + i__) ELEMENT_TYPE__ (%s%S[i__]);",
 421                  elem_ty, "", exp, prefix, exp);
 422          } else
 423          {  C.pr("%^%S[i__] = %s%S[i__];", exp, prefix, exp);
 424          }
 425          C.pr("%-%^}"
 426               "%-%^}");
 427       }
 428    |  _: // skip
 429    }
 430 }
 431
 432 //////////////////////////////////////////////////////////////////////////////
 433 //
 434 //  Methods to generate array initialization code.
 435 //
 436 //////////////////////////////////////////////////////////////////////////////
 437
 438 //////////////////////////////////////////////////////////////////////////////
 439 //
 440 //  Methods to generate destructor code.
 441 //
 442 //////////////////////////////////////////////////////////////////////////////
 443 void DatatypeClass::gen_class_destructor_body(CodeGen& C, Tys tys, DefKind)
 444 {
 445    if (is_array && cons)
 446    {  C.pr("%^{%+"
 447            "%^for (int i__; i__ < len_; i__++)"
 448            "%^{%+"
 449            "%^typedef %t ELEMENT_TYPE;"
 450            "%^(%S+i__)->~ELEMENT_TYPE();"
 451            "%-%^}"
 452            "%-%^}",
 453            cons_arg_ty, "", constructor_name
 454           );
 455    }
 456 }
 457
 458 //////////////////////////////////////////////////////////////////////////////
 459 //
 460 //  Methods to generate the forward declarations for a datatype.
 461 //  These include unit constructors for the class.
 462 //
 463 //////////////////////////////////////////////////////////////////////////////
 464 void DatatypeHierarchy::generate_forward_declarations(CodeGen& C)
 465 {
 466    // don't generate code for views
 467    if (is_view()) return;
 468
 469    get_info();
 470    generate_forward_class_declarations(C);
 471    generate_forward_constructor_declarations(C);
 472
 473    // don't generate code for forward definitions
 474    if (term_defs == #[]) return;
 475
 476    generate_unit_constructors(C);
 477 }
 478
 479 //////////////////////////////////////////////////////////////////////////////
 480 //
 481 //  Method to generate forward class declarations.
 482 //  If the datatype is monomorphic, generate a typedef.
 483 //  Otherwise, generate a forward template declaration
 484 //  and a #define.
 485 //
 486 //////////////////////////////////////////////////////////////////////////////
 487 void DatatypeHierarchy::generate_forward_class_declarations(CodeGen& C)
 488 {  // Generate forward declarations only if we have at least one variant
 489    if (arg_constructors == 0 && term_defs != #[]) return;
 490
 491    C.pr("%^%/"
 492         "%^//"
 493         "%^// Forward class definition for %s%V"
 494         "%^//"
 495         "%^%/"
 496         "%n#ifndef datatype_%S_defined"
 497         "%n#define datatype_%S_defined",
 498         datatype_name, parameters, datatype_name, datatype_name
 499        );
 500
 501    if (is_polymorphic())
 502    {  // Polymorphic datatypes
 503       C.pr("%^%Hclass %s;", parameters, class_name);
 504       C.pr("%n#define %s%v %s%s%V *\n",
 505            datatype_name, parameters, is_const, class_name, parameters);
 506    } else
 507    {  // Monomorphic datatypes
 508       C.pr("%^   class %s;", class_name);
 509       C.pr("%^   typedef %s%s * %s;", is_const, class_name, datatype_name);
 510    }
 511
 512    C.pr("%n#endif\n\n");
 513 }
 514
 515 //////////////////////////////////////////////////////////////////////////////
 516 //
 517 //  Method to generate forward declarations for datatype constructors.
 518 //
 519 //////////////////////////////////////////////////////////////////////////////
 520 void DatatypeHierarchy::generate_forward_constructor_declarations(CodeGen& C)
 521 {
 522 }
 523
 524
 525 //////////////////////////////////////////////////////////////////////////////
 526 //
 527 //  Method to generate code for the definition of a datatype
 528 //
 529 //////////////////////////////////////////////////////////////////////////////
 530 void DatatypeHierarchy::generate_datatype_definitions(CodeGen& C)
 531 {
 532    // don't generate code for views
 533    if (is_view()) return;
 534
 535    // don't generate code for forward definitions
 536    if (term_defs == #[]) return;
 537
 538    // If there are no argument constructors, don't generate code
 539    get_info();
 540
 541    if (arg_constructors == 0)
 542    {
 543       gen_class_postdefinition(C);
 544
 545    } else
 546    {
 547       // Otherwise generate code for all the classes.
 548       gen_class_definition(C);
 549       for (int i = 0; i < number_of_subclasses; i++)
 550          subclasses[i]->gen_class_definition(C);
 551
 552       // Generate datatype constructors
 553       DefKind kind = inline_methods
 554           ? INLINE_IMPLEMENTATION : INTERFACE_DEFINITION;
 555
 556       generate_datatype_constructors(C,#[],kind);
 557
 558       if (options.inline_casts == false || parameters != #[])
 559          generate_downcasting_functions(C);
 560       C.pr("\n\n");
 561    }
 562 }
 563
 564 //////////////////////////////////////////////////////////////////////////////
 565 //
 566 //  Method to generate the unit constructor names.
 567 //  If there are no argument constructors, represent the constructors as
 568 //  enum's.   Otherwise, represent them as #define constants.
 569 //
 570 //////////////////////////////////////////////////////////////////////////////
 571 void DatatypeHierarchy::generate_unit_constructors(CodeGen& C)
 572 {  if (unit_constructors == 0) return;
 573    if (arg_constructors == 0)
 574       generate_constructor_tags(C,"","", unit_constructors, constructor_terms);
 575    else
 576       generate_define_tags(C,unit_constructors,constructor_terms);
 577    C.pr("\n\n");
 578 }
 579
 580 //////////////////////////////////////////////////////////////////////////////
 581 //
 582 //  Method to generate the constructor tags as enum's.
 583 //  Constructor tags are used to represent unit constructors
 584 //  and variant tags.
 585 //
 586 //////////////////////////////////////////////////////////////////////////////
 587 void DatatypeHierarchy::generate_constructor_tags
 588   (CodeGen& C, Id enum_prefix, Id tag_prefix, int n, Cons terms[])
 589 {  C.pr("%^enum %s%s {%+", enum_prefix, datatype_name);
 590    Bool comma = false;
 591    for (int i = 0; i < n; i++)
 592    {  if (comma) C.pr (", ");
 593       if (i % 3 == 0) C.pr("%^");
 594       C.pr("%s%S = %i", tag_prefix, terms[i]->name, tag_of(terms[i]));
 595       comma = true;
 596    }
 597    C.pr("%-%^};\n\n");
 598 }
 599
 600 //////////////////////////////////////////////////////////////////////////////
 601 //
 602 //  Method to generate the unit constructor tags as #define constants.
 603 //  This is necessary if we have both unit and argument constructors
 604 //  for a type.  If polymorphic types are used, the #define constants
 605 //  are not given a type.
 606 //
 607 //////////////////////////////////////////////////////////////////////////////
 608 void DatatypeHierarchy::generate_define_tags(CodeGen& C, int n, Cons terms[])
 609 {  for (int i = 0; i < n; i++)
 610    {  if (is_polymorphic())
 611          C.pr("%n#  define %S %i", terms[i]->name, tag_of(terms[i]));
 612       else
 613          C.pr("%n#  define %S (%s)%i",
 614             terms[i]->name, datatype_name, tag_of(terms[i]));
 615    }
 616 }
 617
 618 //////////////////////////////////////////////////////////////////////////////
 619 //
 620 //  Method to generate datatype constructor functions for a datatype.
 621 //  Datatype constructor functions are just external functions.
 622 //
 623 //////////////////////////////////////////////////////////////////////////////
 624 void DatatypeHierarchy::generate_datatype_constructors
 625    (CodeGen& C, Tys tys, DefKind kind)
 626 {
 627    C.pr("%^%/"
 628         "%^//"
 629         "%^// Datatype constructor functions for %s%V"
 630         "%^//"
 631         "%^%/",
 632         datatype_name, parameters);
 633    generate_datatype_constructor(C,tys,kind);
 634    for (int i = 0; i < number_of_subclasses; i++)
 635    {  subclasses[i]->generate_datatype_constructor(C,tys,kind);
 636    }
 637 }
 638
 639 //////////////////////////////////////////////////////////////////////////////
 640 //
 641 //  Method to generate a datatype constructor function.
 642 //
 643 //////////////////////////////////////////////////////////////////////////////
 644 void DatatypeClass::generate_datatype_constructor
 645    (CodeGen& C, Tys tys, DefKind kind)
 646 {
 647    // No datatype descriptor, then no datatype constructor function
 648    if (cons == NOcons) return;
 649
 650    Id prefix = "";
 651
 652    switch (kind)
 653    {  case INLINE_IMPLEMENTATION:   prefix = "inline "; break;
 654       case INTERFACE_DEFINITION:
 655       case EXTERNAL_DEFINITION:     prefix = "extern "; break;
 656       case EXTERNAL_IMPLEMENTATION:
 657       case EXTERNAL_INSTANTIATION:  prefix = ""; break;
 658    }
 659
 660    // Generate special form constructors for lists and vectors
 661    int special_forms = 1;
 662    if (is_list) special_forms = 2;
 663    else if (is_array) special_forms = options.max_vector_len + 2;
 664    Tys params = #[];
 665    Ids labels = #[];
 666
 667    for (int form = 1; form <= special_forms; form++)
 668    {
 669       Ty formals_ty = cons_arg_ty;
 670       Ty actuals_ty = cons_arg_ty;
 671       Id formals_name = constructor_name;
 672
 673       // If it is a list special form, fake the second argument
 674       if (is_list && form == 2)
 675       {  match (deref(formals_ty))
 676          {  TUPLEty #[a,b]:
 677             {  formals_ty = actuals_ty = mktuplety(#[a]); }
 678          |  t:  { bug("%LDatatypeClass::generate_datatype_constructor: %T\n",
 679                   t); }
 680          }
 681       }
 682
 683       // If it is an array special form, fake the parameter arguments
 684       if (is_array && form >= 2)
 685       {  if (form >= 3)
 686          {  params = #[ cons_arg_ty ... params ];
 687             labels = append(labels,#[index_of(form-2)]);
 688          }
 689          formals_ty = mkrecordty(labels,params,false);
 690          formals_name = mangle(constructor_name);
 691       }
 692
 693       switch (kind)
 694       {  case EXTERNAL_INSTANTIATION:
 695          case EXTERNAL_DEFINITION:
 696            C.pr("%^%s%s%P * %S %b",
 697            prefix, root->class_name, tys, constructor_name,
 698            formals_ty, formals_name, TYsimpleformal);
 699            break;
 700          default:
 701            C.pr("%^%H%s%s%V * %S %b",
 702               parameters,
 703               prefix, root->class_name, parameters, constructor_name,
 704               formals_ty, formals_name, TYformal);
 705            break;
 706       }
 707
 708       //  Don't generate code for interface definitions
 709       if (kind == INTERFACE_DEFINITION ||
 710           kind == EXTERNAL_DEFINITION) { C.pr(";"); continue; }
 711
 712       C.pr("%^{%+");
 713
 714       //
 715       // Generate a temporary array
 716       //
 717       if (is_array && form >= 2)
 718       {  C.pr("%^const int x__len_ = %i;", form - 2);
 719          C.pr("%^%t x_%S[%i];", cons_arg_ty, "", constructor_name, form - 2);
 720          for (int i = 0; i < form - 2; i++)
 721             C.pr("%^x_%S[%i] = x__%i;", constructor_name,i,i+1);
 722       }
 723
 724       C.pr("%^return ");
 725
 726       //
 727       // In the tagged pointer representation, the variant tag is embedded
 728       // within the data address.
 729       //
 730       if (root->optimizations & OPTtaggedpointer)
 731       {  switch (kind)
 732          {  case EXTERNAL_INSTANTIATION:
 733                C.pr ("(%s%P*)((unsigned long)(", root->class_name, tys);
 734                break;
 735             default:
 736                C.pr ("(%s%V*)((unsigned long)(", root->class_name, parameters);
 737                break;
 738          }
 739      }
 740
 741       //
 742       // In the unboxed representation, the argument is embedded within
 743       // the address.
 744       //
 745       if (root->optimizations & OPTunboxed)
 746       {
 747          int tag_bits = DatatypeCompiler::max_embedded_bits;
 748          for (int i = root->unit_constructors;
 749            i >= DatatypeCompiler::max_embedded_tags; i >>= 1) tag_bits++;
 750          C.pr ("(%s *)(((unsigned long)%b<<(%i+1))|%i)",
 751                root->class_name, actuals_ty, constructor_name, TYactual,
 752                tag_bits, (1 << tag_bits));
 753       }
 754
 755       //
 756       // The usual boxed implementation
 757       //
 758       else
 759       {
 760           C.pr ("new ");
 761           switch (kind)
 762           {  case EXTERNAL_INSTANTIATION:
 763                 if (is_array)
 764                    C.pr ("(sizeof(%s%P)+sizeof(%t)*x__len_) ",
 765                       class_name, tys, cons_arg_ty, "");
 766                 C.pr ("%s%P %b", class_name, tys, actuals_ty,
 767                       constructor_name, TYactual);
 768                 break;
 769              default:
 770                 if (is_array)
 771                    C.pr ("(sizeof(%s%V)+sizeof(%t)*x__len_) ",
 772                       class_name, parameters, cons_arg_ty, "");
 773                 C.pr ("%s%V %b", class_name, parameters, actuals_ty,
 774                      constructor_name, TYactual);
 775                 break;
 776           }
 777        }
 778
 779        if (root->optimizations & OPTtaggedpointer)
 780        {  switch (kind)
 781           {  case EXTERNAL_INSTANTIATION:
 782                C.pr (")|%s%P::tag_%S)",
 783                      root->class_name, tys, constructor_name); break;
 784              default:
 785                C.pr (")|%s%V::tag_%S)",
 786                      root->class_name, parameters, constructor_name); break;
 787          }
 788        }
 789
 790        C.pr (";%-%^}\n");
 791    }
 792 }
 793
 794
 795 //////////////////////////////////////////////////////////////////////////////
 796 //
 797 //  Method to generate code before the interface
 798 //
 799 //////////////////////////////////////////////////////////////////////////////
 800 void DatatypeClass::gen_class_predefinition(CodeGen& C)
 801 {
 802    match (cons)
 803    {  ONEcons { ty, name ... }:
 804       {  cons_arg_ty = ty;
 805          C.pr("%^%/"
 806               "%^//"
 807               "%^// Class for datatype constructor %s%V::%s"
 808               "%^//"
 809               "%^%/",
 810               root->datatype_name, parameters, name);
 811       }
 812    |  NOcons:
 813       {  cons_arg_ty = NOty;
 814          C.pr("%^%/"
 815            "%^//"
 816            "%^// Base class for datatype %s%V"
 817            "%^//"
 818            "%^%/",
 819            root->datatype_name, parameters);
 820       }
 821    }
 822 }
 823
 824 //////////////////////////////////////////////////////////////////////////////
 825 //
 826 // Method to generate the interface of a class
 827 //
 828 //////////////////////////////////////////////////////////////////////////////
 829 void DatatypeClass::gen_class_interface(CodeGen& C)
 830 {
 831    // Generate the internal representation
 832    // if there is a constructor descripter and the
 833    // argument is not represented in unboxed form.
 834    C.pr("%-%^public:%+");
 835    match (cons)
 836    {  ONEcons { name, opt, ty, location ... }:
 837       {  if ((opt & OPTunboxed) == 0)
 838          {  C.pr ("%#%^%b\n", location->begin_line, location->file_name,
 839                    ty, name, TYbody);
 840          }
 841       }
 842    |  _: // skip
 843    }
 844
 845    DefKind kind = root->inline_methods
 846       ? INLINE_IMPLEMENTATION : INTERFACE_DEFINITION;
 847
 848    // Generate the constructor of the class
 849    if (cons != NOcons)
 850    {  gen_class_constructor(C, #[], kind);
 851    }
 852
 853    // Generate the destructor of the class
 854    if ((root->qualifiers & QUALvirtualdestr) ||
 855        (qualifiers & QUALvirtualdestr) ||
 856        (cons && is_array))
 857        gen_class_destructor(C, #[], kind);
 858
 859    // Generate the method declarations for all different types
 860    // of extra functionality
 861    if (root->qualifiers & QUALpersistent)  generate_persistence_interface(C);
 862    //if (root->qualifiers & QUALvariable)    generate_logic_interface(C);
 863    if (root->qualifiers & QUALcollectable) generate_gc_interface(C);
 864    if (root->qualifiers & QUALrelation)    generate_inference_interface(C);
 865 }
 866
 867 //////////////////////////////////////////////////////////////////////////////
 868 //
 869 // Method to generate the interface of a base class
 870 //
 871 //////////////////////////////////////////////////////////////////////////////
 872 void DatatypeHierarchy::gen_class_interface(CodeGen& C)
 873 {
 874    // Generate tags for arg constructors
 875    if (arg_constructors > 1)
 876    {  C.pr("%-%^public:%+");
 877       generate_constructor_tags(C,"Tag_","tag_",
 878          arg_constructors, constructor_terms + unit_constructors);
 879    }
 880
 881    // Generate a variant tag and a base class constructor for it
 882    // only if we have a variant_tag representation.
 883    if (has_variant_tag)
 884    {  C.pr("%-%^public:%+"
 885            "%^const Tag_%s tag__; // variant tag"
 886            "%-%^protected:%+"
 887            "%^inline %s(Tag_%s t__) : tag__(t__) {%&}",
 888            datatype_name, class_name, datatype_name, constructor_code
 889           );
 890    }
 891
 892    // Generate the untagging functions
 893    generate_untagging_member_functions(C);
 894
 895    DatatypeClass::gen_class_interface(C);
 896 }
 897
 898 //////////////////////////////////////////////////////////////////////////////
 899 //
 900 //  Method to generate untagging functions for a datatype class.
 901 //  Three untagging functions are generated:
 902 //      int untag() const  --- returns the variant tag of the class
 903 //      friend int untag(type * x) -- return a tag for the object x
 904 //                                    so that each variant (boxed or unboxed)
 905 //                                    gets a unique tag.
 906 //      friend int boxed(type * x) -- returns true if object is boxed.
 907 //
 908 //////////////////////////////////////////////////////////////////////////////
 909 void DatatypeHierarchy::generate_untagging_member_functions(CodeGen& C)
 910 {
 911    ///////////////////////////////////////////////////////////////////////////
 912    // Generate untagger
 913    ///////////////////////////////////////////////////////////////////////////
 914    // if (has_variant_tag)
 915    //    C.pr("%^inline int untag() const { return tag__; }");
 916 }
 917
 918 void DatatypeHierarchy::generate_untagging_functions(CodeGen& C)
 919 {
 920
 921    if (arg_constructors == 0) return;
 922
 923    ///////////////////////////////////////////////////////////////////////////
 924    // Generate boxed() predicate
 925    ///////////////////////////////////////////////////////////////////////////
 926    if (unit_constructors == 0)
 927       C.pr("%^%Hinline int boxed(const %s%V *) { return 1; }",
 928            parameters, class_name, parameters);
 929    else if (unit_constructors == 1)
 930       C.pr("%^%Hinline int boxed(const %s%V * x) { return x != 0; }",
 931            parameters, class_name, parameters);
 932    else
 933       C.pr("%^%Hinline int boxed(const %s%V * x)"
 934            " { return (unsigned long)x >= %i; }",
 935            parameters, class_name, parameters, unit_constructors);
 936
 937    ///////////////////////////////////////////////////////////////////////////
 938    // Generate function that untags the pointer if
 939    // the tags are embedded into a pointer.
 940    ///////////////////////////////////////////////////////////////////////////
 941    if (optimizations & OPTtaggedpointer)
 942    {  C.pr("%^%/"
 943            "%^//"
 944            "%^// Embbeded tag extraction functions"
 945            "%^//"
 946            "%^%/"
 947            "%^%Hinline int untagp(const %s%V * x)"
 948            "%^   { return (unsigned long)x & %i; }"
 949            "%^%Hinline %s%s%V * derefp(const %s%V * x)"
 950            "%^   { return (%s%s%V*)((unsigned long)x & ~%i); }",
 951            parameters, class_name, parameters,
 952            DatatypeCompiler::max_embedded_tags - 1,
 953            parameters,is_const,class_name, parameters, class_name, parameters,
 954            is_const, class_name, parameters,
 955            DatatypeCompiler::max_embedded_tags - 1);
 956    }
 957
 958    ///////////////////////////////////////////////////////////////////////////
 959    // Generate a generic untag function that works on all boxed
 960    // and unboxed variants.
 961    ///////////////////////////////////////////////////////////////////////////
 962    if (unit_constructors == 0) {
 963       // No unboxed variants.
 964       if (optimizations & OPTtaggedpointer)
 965          C.pr("%^%Hinline int untag(const %s%V * x) { return untagp(x); }",
 966               parameters, class_name, parameters);
 967       else if (arg_constructors == 1)
 968          C.pr("%^%Hinline int untag(const %s%V *) { return 0; }",
 969               parameters, class_name, parameters);
 970       else
 971          C.pr("%^%Hinline int untag(const %s%V * x) { return x->tag__; }",
 972               parameters, class_name, parameters);
 973    } else if (unit_constructors == 1) {
 974       // Only one unboxed variants.
 975       if (optimizations & OPTtaggedpointer)
 976          C.pr("%^%Hinline int untag(const %s%V * x) "
 977               "{ return x ? untagp(x)+1 : 0; }",
 978               parameters, class_name, parameters);
 979       else if (arg_constructors == 1)
 980          C.pr("%^%Hinline int untag(const %s%V * x) { return x ? 1 : 0; }",
 981               parameters, class_name, parameters);
 982       else
 983          C.pr("%^%Hinline int untag(const %s%V * x)"
 984               " { return x ? (x->tag__+1) : 0; }",
 985               parameters, class_name, parameters);
 986    } else {
 987       // More than one unboxed variants.
 988       if (optimizations & OPTtaggedpointer)
 989          C.pr("%^%Hinline int untag(const %s%V * x)"
 990               " { return boxed(x) ? untagp(x) + %i : (int)x; }",
 991               parameters, class_name, parameters, unit_constructors);
 992       else if (arg_constructors == 1)
 993          C.pr("%^%Hinline int untag(const %s%V * x)"
 994               " { return boxed(x) ? %i : (int)x; }",
 995               parameters, class_name, parameters, 1 + unit_constructors);
 996       else
 997          C.pr("%^%Hinline int untag(const %s%V * x)"
 998               " { return boxed(x) ? x->tag__ + %i : (int)x; }",
 999               parameters, class_name, parameters, unit_constructors);
1000    }
1001 }
1002
1003 //////////////////////////////////////////////////////////////////////////////
1004 //
1005 // Method to generate downcasting functions
1006 //
1007 //////////////////////////////////////////////////////////////////////////////
1008 void DatatypeHierarchy::generate_downcasting_functions(CodeGen& C)
1009 {
1010    C.pr("%^%/"
1011         "%^//"
1012         "%^// Downcasting functions for %s%V"
1013         "%^//"
1014         "%^%/",
1015         datatype_name, parameters);
1016    for (int i = 0; i < number_of_subclasses; i++)
1017    {  DatatypeClass * D = subclasses[i];
1018       C.pr("%^%Hinline %s%V * _%S(const %s%V * _x_) { return (%s%V *)_x_; }",
1019            parameters, D->class_name, parameters, D->constructor_name,
1020            class_name, parameters, D->class_name, parameters);
1021    }
1022 }
1023
1024 //////////////////////////////////////////////////////////////////////////////
1025 //
1026 //  Method to generate code right after the main class definition.
1027 //
1028 //////////////////////////////////////////////////////////////////////////////
1029 void DatatypeClass::gen_class_postdefinition(CodeGen& C)
1030 {
1031    C.pr("\n");
1032
1033    // Interfaces for extra features
1034    if (root->qualifiers & QUALprintable) generate_print_interface(C);
1035 }
1036
1037 //////////////////////////////////////////////////////////////////////////////
1038 //
1039 //  Method to generate code right after the main class definition.
1040 //
1041 //////////////////////////////////////////////////////////////////////////////
1042 void DatatypeHierarchy::gen_class_postdefinition(CodeGen& C)
1043 {
1044    generate_untagging_functions(C);
1045    DatatypeClass::gen_class_postdefinition(C);
1046 }
1047