prop-src/datagen.pcc.old

   1 ///////////////////////////////////////////////////////////////////////////////
   2 //
   3 //  This file implements the datatype compiler of Prop.
   4 //
   5 ///////////////////////////////////////////////////////////////////////////////
   6
   7 #include <iostream.h>
   8 #include <AD/strings/quark.h>
   9 #include "ir.ph"
  10 #include "ast.ph"
  11 #include "type.h"
  12 #include "datagen.h"
  13 #include "options.h"
  14
  15 ///////////////////////////////////////////////////////////////////////////////
  16 //
  17 //  Constructor and destructors for datatype compiler
  18 //
  19 ///////////////////////////////////////////////////////////////////////////////
  20 DatatypeCompiler:: DatatypeCompiler(TyOpt opt, int embedded_tags)
  21    : optimizations(opt),
  22      max_embedded_tags(embedded_tags),
  23      temp_vars("_T")
  24      {  max_embedded_bits = 0;
  25         for (int i = embedded_tags - 1; i > 0; i >>= 1)
  26            max_embedded_bits++;
  27      }
  28 DatatypeCompiler::~DatatypeCompiler() {}
  29
  30 ///////////////////////////////////////////////////////////////////////////////
  31 //
  32 //  Top level method to map datatype and type definitions into
  33 //  a C++ class hierarchy.
  34 //
  35 ///////////////////////////////////////////////////////////////////////////////
  36 void DatatypeCompiler::gen_datatype
  37    (DatatypeDefs data_defs, ViewDefs view_defs,
  38     LawDefs law_defs, TyDefs ty_defs)
  39 {
  40    //  Generate forward definitions
  41    {  for_each (DatatypeDef, d, data_defs) gen_forward_def(d); }
  42    {  for_each (TyDef, t, ty_defs)         gen_type_def(t); }
  43
  44    //  Generate the class hierarchies
  45    {  for_each (DatatypeDef, d, data_defs) gen_class_hierarchy(d); }
  46
  47    //  Compile the pattern laws
  48    gen_law_defs(law_defs);
  49 }
  50
  51 ///////////////////////////////////////////////////////////////////////////////
  52 //
  53 //  Method to generate a forward datatype definitions
  54 //
  55 ///////////////////////////////////////////////////////////////////////////////
  56 void DatatypeCompiler::gen_forward_def(DatatypeDef data_def)
  57 {  match (data_def)
  58    {  DATATYPEdef(id,tyvars,_,qual,terms,_) | (qual & QUALview) == 0:
  59       {
  60          if (terms != #[]) {
  61             match (lookup_ty(id))
  62             {  TYCONty(DATATYPEtycon
  63                   { id, unit, arg, terms, opt, qualifiers ... },_):
  64                {  if (arg == 0) // all unit constructors, generate them
  65                      gen_unit_constructors(id,unit,terms,false,qualifiers & QUALlexeme);
  66                   else { // otherwise
  67                      gen_forward_class_def(id, tyvars, qualifiers);
  68                      gen_forward_arg_constructors(id,tyvars,unit,arg,opt,terms);
  69                   }
  70                }
  71             |  _:  { bug ("gen_forward_def()"); }
  72             }
  73          } else {
  74             gen_forward_class_def(id, tyvars, qual);
  75          }
  76       }
  77    |  _: // skip views
  78    }
  79 }
  80
  81 ///////////////////////////////////////////////////////////////////////////////
  82 //
  83 //  Print a forward class definition for variant types.
  84 //
  85 ///////////////////////////////////////////////////////////////////////////////
  86 void DatatypeCompiler::gen_forward_class_def(Id id, TyVars tyvars, TyQual qual)
  87 {
  88    pr ("%^%/%^// Forward class definition for %s%V%^%/"
  89        "%n#ifndef datatype_%s_defined\n"
  90        "%n#define datatype_%s_defined\n",
  91        id, tyvars, id, id);
  92    Id is_const = (qual & QUALconst) ? "const " : "";
  93    if (tyvars)
  94       pr ("#   define %s%v %sa_%s%V *\n", id, tyvars, is_const, id, tyvars);
  95    else
  96       pr ("%^   typedef %sclass a_%s * %s;\n", is_const, id, id);
  97    pr ("#endif\n\n");
  98 }
  99
 100 ///////////////////////////////////////////////////////////////////////////////
 101 //
 102 //  Method to map unit constructors as enum's.
 103 //
 104 ///////////////////////////////////////////////////////////////////////////////
 105 void DatatypeCompiler::gen_unit_constructors
 106    (Id id, int n, Cons terms[], Bool intern, Bool is_lexeme)
 107 {
 108    if (intern)
 109       pr ("%^enum Tag_%s {\n%+",id);
 110    else
 111       pr ("%^%/%^// Definition of datatype '%s'%^%/%^enum %s {\n%+",id,id);
 112    int count = 0;
 113    Bool comma = false;
 114    for (int i = 0; i < n; i++)
 115    {  match (terms[i])
 116       {  ONEcons { name, tag, ty ... }:
 117          {  if (! (intern && ty == NOty)) {
 118                if (comma) pr (", ");
 119                if ((count % 4) == 0) pr ("%^");
 120                if (intern) pr ("tag_");
 121                pr ("%S = %i", name, tag_of(terms[i]));
 122                comma = true;
 123                count++;
 124             }
 125          }
 126       |  _: { /* skip */ }
 127       }
 128    }
 129    pr ("%-%^};\n\n");
 130 }
 131
 132 ///////////////////////////////////////////////////////////////////////////////
 133 //
 134 //  Method to generate forward class definitions for
 135 //  a datatype with arguments.
 136 //
 137 ///////////////////////////////////////////////////////////////////////////////
 138 void DatatypeCompiler::gen_forward_arg_constructors
 139    (Id id, TyVars tyvars, int unit, int arg, TyOpt opt, Cons terms[])
 140 {  int arity = unit + arg;
 141    pr ("%^%/%^// Class hierarchy for datatype %s%V%^%/"
 142        "%^%Hclass a_%s; // base class for datatype %s%V\n",
 143        id, tyvars, tyvars, id, id, tyvars);
 144    if ((opt & OPTsubclassless) == 0) {
 145       pr ("%+");
 146       for (int i = 0; i < arity; i++)
 147       {  match (terms[i])
 148          {  ONEcons { name, ty = ty as ! NOty, opt ... }:
 149             {  pr ("%^%Hclass %s_%S;\t// subclass for '%s %T'\n",
 150                    tyvars, id, name, name, ty);
 151             }
 152          |  _:  { /* skip */ }
 153          }
 154       }
 155       pr ("%-");
 156    }
 157    pr ("\n");
 158 }
 159
 160 ///////////////////////////////////////////////////////////////////////////////
 161 //
 162 //  Method to generate a forward type definition
 163 //
 164 ///////////////////////////////////////////////////////////////////////////////
 165 void DatatypeCompiler::gen_type_def (TyDef ty_def)
 166 {  match (ty_def)
 167    {  TYdef(id,tyvars,ty,generative) | generative:
 168       {  pr ("%^%/%^// Definition of type %s%V%^%/"
 169              "%#"
 170              "%^%^typedef %t;\n\n",
 171              id, tyvars, ty_def->begin_line, ty_def->file_name, ty, id);
 172       }
 173    |  _: /* skip */
 174    }
 175 }
 176
 177 ///////////////////////////////////////////////////////////////////////////////
 178 //
 179 //  Method to generate the class hierarchy
 180 //
 181 ///////////////////////////////////////////////////////////////////////////////
 182 void DatatypeCompiler::gen_class_hierarchy(DatatypeDef d)
 183 {  match (d)
 184    {  DATATYPEdef(id,tyvars,_,this_qual,_,_) | (this_qual & QUALview) == 0:
 185       {  match (lookup_ty(id))
 186          {  TYCONty(DATATYPEtycon { id, unit, arg, terms, inherit,
 187                                     qualifiers, opt, body ... },_):
 188             {  if (arg > 0) {
 189                   Bool has_subclass =
 190                      gen_base_class(id,tyvars,unit,arg,opt,terms,inherit,
 191                                  qualifiers,body);
 192                   // If we have no subclass and no virtual functions
 193                   // then don't inherit from the base class at all!
 194                   // if (! has_subclass && (opt & OPTtagless) &&
 195                   //     (qualifiers & QUALvirtualdestr) == 0)
 196                   //    opt |= OPTbaseclassless;
 197                   int arity = unit + arg;
 198                   if ((opt & OPTsubclassless) == 0)
 199                      for (int i = 0; i < arity; i++)
 200                         if (terms[i]->ty != NOty)
 201                            gen_subclass(id, tyvars, unit, arg, opt,
 202                                         qualifiers, terms[i]);
 203                   if ((opt & OPTsubclassless) == 0 && tyvars != #[])
 204                      gen_downcasting_functions
 205                         (id, tyvars, unit + arg, terms, qualifiers);
 206               }
 207
 208               //  If the class is unifiable, generate the dereference method
 209               if (qualifiers & QUALunifiable)
 210               {  Id var_name  = terms[unit]->name;
 211                  Id down_cast = (opt & OPTsubclassless) ? ""
 212                                    : Quark("_",mangle(var_name)).string();
 213                  pr("%^%/"
 214                     "%^//  Variable dereferencing method"
 215                     "%^%/"
 216                     "%^%Hinline %s%v deref_var(%s%v _x_)"
 217                     "%^{  while (untag(_x_) == %i && %s(_x_)->%S != _x_)"
 218                     "%^      _x_ = %s(_x_)->%S;"
 219                     "%^   return _x_;"
 220                     "%^}\n\n",
 221                     tyvars, id, tyvars, id, tyvars,
 222                     unit, down_cast, var_name, down_cast, var_name,
 223                     id, tyvars);
 224               }
 225
 226               if ((qualifiers & QUALprintable) && tyvars == 0)
 227                  pr ("%^%Hostream& operator << (ostream&,%s%v);"
 228                      "%^%Hostream& pretty_print(ostream&,%s%v,int = 0,int = 0);\n\n",
 229                      tyvars, id, tyvars, tyvars, id, tyvars);
 230             }
 231          |  _: { /* skip */ }
 232          }
 233       }
 234    |  _:  // skip views
 235    }
 236 }
 237
 238 ///////////////////////////////////////////////////////////////////////////////
 239 //
 240 //  Print a subclass
 241 //
 242 ///////////////////////////////////////////////////////////////////////////////
 243 void DatatypeCompiler::pr_subclass(Bool& subclass, Id name)
 244 {  pr (subclass ? ", " : " : ");
 245    pr ("public %s",name);
 246    subclass = true;
 247 }
 248
 249 ///////////////////////////////////////////////////////////////////////////////
 250 //
 251 //  Do we need to inherit from a subclass?  Do so only if the qualifier
 252 //  has been declared and the user defined class have not inherit from the
 253 //  same class.
 254 //
 255 ///////////////////////////////////////////////////////////////////////////////
 256 static Bool need_subclass (TyQual q, TyQual qualifier, Inherits superclasses)
 257 {  if ((q & qualifier) == 0) return false;
 258    for_each(Inherit, i, superclasses)
 259    {  if ((i.qualifiers & q) || has_qual(q,i.super_class)) return false;
 260    }
 261    return true;
 262 }
 263
 264 ///////////////////////////////////////////////////////////////////////////////
 265 //
 266 //  Method to generate the base class
 267 //
 268 ///////////////////////////////////////////////////////////////////////////////
 269 Bool DatatypeCompiler::gen_base_class
 270    (Id id, TyVars tyvars,
 271     int unit, int arg, TyOpt opt, Cons terms[], Inherits inherit,
 272     TyQual qualifiers, Decls body)
 273 {  int arity = unit + arg;
 274
 275    pr ("%^%/%^// Base class for datatype '%s%V'%^%/%^", id, tyvars);
 276    if (tyvars) pr ("%H%+%^", tyvars);
 277    pr ("class a_%s", id);
 278
 279    Bool subclass = false;
 280    // if (qualifiers & QUALunifiable)   pr_subclass (subclass,"LogicalTerm");
 281    if (need_subclass(QUALcollectable,qualifiers, inherit))
 282       pr_subclass (subclass,"GCObject");
 283    if (need_subclass(QUALpersistent,qualifiers, inherit))
 284       pr_subclass (subclass,"PObject");
 285    if (qualifiers & QUALrelation)    pr_subclass (subclass,"Fact");
 286    if (qualifiers & QUALrewritable)  pr_subclass (subclass,"TermObj");
 287
 288    if (inherit != #[]) {
 289       pr (subclass ? ", " : " : ");
 290       pr ("%I",inherit);
 291       subclass = true;
 292    }
 293
 294    pr (" {\n%^public:%+");
 295
 296    for (int i = 0; i < arity; i++)
 297    {  match (terms[i])
 298       {  ONEcons { name, ty = NOty, tag ... }:
 299          { if (tyvars)
 300               pr ("%n#  define %S %i\n", name, tag);
 301            else
 302               pr ("%n#  define %S (%s)%i\n",name, id, tag);
 303          }
 304       |  _:  { /* skip */ }
 305       }
 306    }
 307
 308    if ((opt & OPTtagless) == 0 || (opt & OPTtaggedpointer))
 309       gen_unit_constructors (id,arity,terms,true);
 310    if ((opt & OPTtagless) == 0) {
 311       pr ("%-%^protected:%+"
 312           "%^const Tag_%s _tag_;"
 313           "%^inline a_%s(Tag_%s _t_) : _tag_(_t_) {}"
 314           "%-%^public:%+",
 315           id, id, id);
 316    }
 317
 318    gen_untagging_functions   (id, tyvars, unit, arg, qualifiers, opt);
 319
 320    if (opt & OPTsubclassless) {
 321       for (int i = 0; i < arity; i++)
 322       {  match (terms[i])
 323          {  ONEcons { name, location, ty = ty as ! NOty, opt = my_opt,
 324                       qual = cons_qual ... }:
 325             {  if ((my_opt & OPTunboxed) == 0) {
 326                   pr ("%#%^%b\n", location->begin_line, location->file_name,
 327                       ty, name, TYbody);
 328                   gen_class_constructor(id,tyvars,name,unit,arg,opt,ty,true,cons_qual);
 329                }
 330                gen_datatype_constructor
 331                   (id,tyvars,name,unit,arg,opt | my_opt,ty,true,cons_qual);
 332                gen_class_destructor(id,tyvars,name,ty,qualifiers,opt | my_opt,true);
 333             }
 334          |  _: { /* skip */ }
 335          }
 336       }
 337    } else {
 338       gen_class_destructor(id,tyvars,0,NOty,qualifiers,opt,true);
 339    }
 340
 341    if (qualifiers & QUALrelation)
 342       pr ("%^static  RelTag relation_tag;"
 343           "%^virtual RelTag get_tag() const;\n");
 344
 345    if ((opt & OPTsubclassless) == 0 && tyvars == #[])
 346       gen_downcasting_functions (id, tyvars, unit + arg, terms, qualifiers);
 347    gen_class_interface(id, tyvars, 0, qualifiers, opt, 0);
 348
 349    pr ("%&",body);
 350
 351    pr ("%-%^};\n\n");
 352    if (tyvars) pr ("%-");
 353
 354    return subclass;
 355 }
 356
 357 ///////////////////////////////////////////////////////////////////////////////
 358 //
 359 //  Method to generate the untagging functions of a class
 360 //
 361 ///////////////////////////////////////////////////////////////////////////////
 362 void DatatypeCompiler::gen_untagging_functions
 363    (Id id, TyVars tyvars, int unit, int arg, TyQual qual, TyOpt opt)
 364 {
 365    Id is_const = (qual & QUALconst) ? "const " : "";
 366
 367    ///////////////////////////////////////////////////////////////////////////
 368    // Generate untagger.
 369    ///////////////////////////////////////////////////////////////////////////
 370    if ((opt & OPTtagless) == 0)
 371       pr ("%^inline int untag() const { return _tag_; }\n");
 372
 373    ///////////////////////////////////////////////////////////////////////////
 374    // Generate function that checks for boxity.
 375    ///////////////////////////////////////////////////////////////////////////
 376    pr ("%^inline friend int boxed(const a_%s * x) { return ", id);
 377    if (unit == 0) pr ("1");
 378    else if (unit == 1) pr ("x != 0");
 379    else pr ("(unsigned long)x >= %i", unit);
 380    pr ("; }\n");
 381
 382    ///////////////////////////////////////////////////////////////////////////
 383    // Generate function that untags the pointer if
 384    // the tags are embedded into a pointer.
 385    ///////////////////////////////////////////////////////////////////////////
 386    if (opt & OPTtaggedpointer)
 387    {  pr ("%^inline friend int untagp(const a_%s * x)"
 388           "%^   { return (unsigned long)x & %i; }"
 389           "%^inline friend %sa_%s * derefp(const a_%s * x)"
 390           "%^   { return (%sa_%s*)((unsigned long)x & ~%i); }",
 391           id, max_embedded_tags - 1,
 392           is_const, id, id, is_const, id, max_embedded_tags - 1);
 393    }
 394
 395    ///////////////////////////////////////////////////////////////////////////
 396    // Generate a generic untag function that works on all boxed
 397    // and unboxed variants.
 398    ///////////////////////////////////////////////////////////////////////////
 399    pr ("%^inline friend int untag(const a_%s * x) { return ", id);
 400    if (unit == 0) {
 401       // No unboxed variants.
 402       if (opt & OPTtaggedpointer) pr ("untagp(x)");
 403       else if (arg == 1)          pr ("0");
 404       else                        pr ("x->_tag_");
 405    } else if (unit == 1) {
 406       // Only one unboxed variants.
 407       if (opt & OPTtaggedpointer) pr ("x ? untagp(x)+1 : 0");
 408       else if (arg == 1)          pr ("x ? 1 : 0");
 409       else                        pr ("x ? (x->_tag_+1) : 0");
 410    } else {
 411       // More than one unboxed variants.
 412       if (opt & OPTtaggedpointer)
 413          pr ("boxed(x) ? untagp(x) + %i : (unsigned long)x", unit);
 414       else if (arg == 1)
 415          pr ("boxed(x) ? %i : (unsigned long)x", 1 + unit);
 416       else
 417          pr ("boxed(x) ? x->_tag_ + %i : (unsigned long)x", unit);
 418    }
 419    pr ("; }\n");
 420 }
 421
 422 ///////////////////////////////////////////////////////////////////////////////
 423 //
 424 //  Method to generate the downcasting functions of a class
 425 //
 426 ///////////////////////////////////////////////////////////////////////////////
 427 void DatatypeCompiler::gen_downcasting_functions
 428    (Id id, TyVars tyvars, int n, Cons terms[], TyQual qual)
 429 {  //if (inline_casts && tyvars == #[]) return;
 430    Id is_const = (qual & QUALconst) ? "const " : "";
 431    pr ("%^%/"
 432        "%^// Downcasting functions for %s%V"
 433        "%^%/",
 434        id, tyvars
 435       );
 436
 437    Cons var_cons = NOcons;
 438
 439    for (int i = 0; i < n; i++)
 440    {  match (terms[i])
 441       {  ONEcons { name, ty = ty as (! NOty), qual ... }:
 442          {
 443             pr ("%^%Hinline %s%s%s_%S%V * _%S(%s%v _x_) "
 444                 "{ return (%s%s_%S%V *)_x_; }\n",
 445                 tyvars, (tyvars == #[] ? "friend " : ""), is_const,
 446                 id, name, tyvars, name, id, tyvars,
 447                 is_const, id, name, tyvars);
 448              if (qual & QUALvariable) var_cons = terms[i];
 449          }
 450       |  _: { /* skip */ }
 451       }
 452    }
 453 }
 454
 455 ///////////////////////////////////////////////////////////////////////////////
 456 //
 457 //  Method to generate a subclass class
 458 //
 459 ///////////////////////////////////////////////////////////////////////////////
 460 void DatatypeCompiler::gen_subclass
 461    (Id id, TyVars tyvars, int unit, int arg, TyOpt opt, TyQual qual, Cons term)
 462 {
 463    match (term)
 464    {  ONEcons { name, ty, location, inherit, body, opt = my_opt,
 465                 qual = cons_qual ... }:
 466       {  // header
 467          pr ("%^%/%^// class for constructor '%s%V::%s %T'%^%/%^",
 468              id, tyvars, name, ty);
 469          if (tyvars) pr("%H%+%^", tyvars);
 470          pr ("class %s_%S ", id, name);
 471          if ((opt & OPTbaseclassless) == 0)
 472             pr (": public a_%s%V%s%I ",
 473                 id, tyvars, (inherit ? ", " : ""), inherit);
 474          // contents of body
 475          pr ("{\n%^public:%+"
 476              "%#%^%b\n", location->begin_line, location->file_name,
 477                          ty, name, TYbody);
 478
 479          // constructor for class
 480          gen_class_constructor(id,tyvars,name,unit,arg,opt,ty,true,cons_qual);
 481
 482          // generate datatype constructor
 483          gen_datatype_constructor(id,tyvars,name,unit,arg,opt | my_opt,ty,true,cons_qual);
 484
 485          // destructor for class
 486          gen_class_destructor(id,tyvars,name,ty,qual,opt | my_opt,true);
 487
 488          // optional methods
 489          gen_class_interface(id,tyvars,name,qual,opt,cons_qual);
 490
 491          if (body) pr ("%^%&", body);
 492          pr ("%-%^};\n\n");
 493          if (tyvars) pr("%-");
 494       }
 495    |  _: { /* skip */ }
 496    }
 497 }
 498
 499 ///////////////////////////////////////////////////////////////////////////////
 500 //
 501 //  Method to generate the class interface functions.
 502 //
 503 ///////////////////////////////////////////////////////////////////////////////
 504 void DatatypeCompiler::gen_class_interface
 505    (Id id, TyVars tyvars, Id name, TyQual qual, TyOpt opt, TyQual cons_qual)
 506 {
 507    Id class_name = ((opt & OPTsubclassless) ? "a" : id);
 508    Id cons_name  = ((opt & OPTsubclassless) ? id : mangle(name));
 509
 510    if (qual & QUALcollectable)
 511    {  pr ("%^%/"
 512           "%^// Method for garbage collection tracing"
 513           "%^%/"
 514           "%-%^protected:%+"
 515           "%^virtual void trace(GC *);\n"
 516           "%-%^public:%+"
 517          );
 518    }
 519
 520    if (cons_qual & QUALvariable)
 521    {  pr ("%^%/"
 522           "%^// Method for logical variable manipulation"
 523           "%^%/"
 524           "%^inline void uninstantiate() { %s = this; }\n", cons_name);
 525    }
 526
 527    if (qual & QUALpersistent)
 528    {  pr ("%^%/"
 529           "%^// Methods for persistence and object serialization"
 530           "%^%/"
 531           "%-%^protected:%+"
 532           "%^virtual const PObjectType& persist_type_id () const;"
 533           "%^virtual Pistream&          persist_read    (Pistream&);"
 534           "%^virtual Postream&          persist_write   (Postream&) const;"
 535           "%-%^public:%+"
 536          );
 537
 538       Bool need_default_constructor = (opt & OPTsubclassless) || name;
 539
 540       if (need_default_constructor)
 541       {  Id prefix = name ? id : "a";
 542          Id suffix = name ? name : id;
 543          pr ("%-%^private:%+"
 544              "%^%/"
 545              "%^// Default constructor used in persistence object factory"
 546              "%^%/"
 547              "%^friend class PObjectFactory< %s_%S%V >;",
 548              prefix, suffix, tyvars);
 549          if (name)
 550          {  pr ("%^inline %s_%S() : a_%s%V(a_%s%V::tag_%S) {}",
 551                 prefix, suffix, id, tyvars, id, tyvars, name);
 552          } else
 553          {  pr ("%^inline %^%a_%s() {}", id);
 554          }
 555          pr ("%-%^public:%+");
 556       }
 557    }
 558 }
 559
 560 ///////////////////////////////////////////////////////////////////////////////
 561 //
 562 //  Method to generate a C++ class constructor for a datatype
 563 //
 564 ///////////////////////////////////////////////////////////////////////////////
 565 void DatatypeCompiler::gen_class_constructor
 566    (Id id, TyVars tyvars, Id name, int unit, int arg, TyOpt opt, Ty ty, Bool def,
 567     TyQual qual)
 568 {  Bool comma = false;
 569    Bool has_array = false;
 570    Bool interface_only = def && tyvars == #[] && options.save_space;
 571    Bool is_array_con = is_array_constructor(name);
 572    Bool is_variable  = qual & QUALvariable;
 573    Id class_name = ((opt & OPTsubclassless) ? "a" : id);
 574    Id cons_name  = ((opt & OPTsubclassless) ? id : mangle(name));
 575
 576    // constructor header
 577    pr ((is_variable ? "%^%s%s%s%s%s%s_%S ()" : "%^%s%s%s%s%s%s_%S %b"),
 578        (interface_only ? "" : "inline "),
 579        (def ? "" : class_name), (def ? "" : "_"),
 580        (def ? "" : cons_name), (def ? "" : "::"),
 581        class_name, cons_name, ty, name, TYformal);
 582
 583    if (interface_only) { pr (";\n"); return; }
 584
 585    // variant tag binding
 586    if (opt & OPTtagless)
 587    {  pr ("%^   : ");
 588    } else
 589    {  pr ("%^   : a_%s%V(a_%s%V::tag_%S)", id, tyvars, id, tyvars, name);
 590       comma = true;
 591    }
 592
 593    // array length binding
 594    if (is_array_con)
 595    {  if (comma) pr (", ");
 596       pr ("len_(_x_len_)");
 597       comma = true;
 598       ty = mkarrayty(ty, IDexp("_x_len_"));
 599       has_array = true;
 600    }
 601
 602    // bindings of non-array components
 603    if (! is_array_con)
 604    match (deref(ty))
 605    {  TYCONty(TUPLEtycon, tys):
 606       {  int i = 1;
 607          for(Tys t = tys; t; t = t->#2) {
 608             if (! is_array_ty(t->#1)) {
 609                if (comma) pr (", "); pr ("_%i(_x%i)", i, i); comma = true;
 610             } else has_array = true;
 611             i++;
 612          }
 613       }
 614    |  TYCONty(RECORDtycon (labs,_), tys):
 615       {  Ids l; Tys t;
 616          for (l = labs, t = tys; l && t; l = l->#2, t = t->#2) {
 617             if (! is_array_ty(t->#1)) {
 618                if (comma) pr (", "); pr ("%s(_x%s)", l->#1, l->#1);
 619                comma = true;
 620             } else has_array = true;
 621          }
 622       }
 623    |  ty:
 624       {  if (! is_array_ty(ty)) {
 625             if (comma) pr (", ");
 626             pr ((is_variable ? "%S(this)" : "%S(_x%S)"),name,name);
 627          }
 628       }
 629    }
 630
 631    // bindings of array components
 632    if (has_array) {
 633       pr ("%^{\n%+%^int _i_;\n");
 634       match (deref(ty))
 635       {  TYCONty(TUPLEtycon, tys):
 636          {  int i = 1;
 637             for(Tys t = tys; t; t = t->#2) {
 638                match (t->#1)
 639                {  TYCONty(ARRAYtycon (e as (! NOexp)),_):
 640                   {  pr ("%^for (_i_ = (%e) - 1; _i_ >= 0; _i_--)\n"
 641                          "%^{ _%i[_i_] = _x%i[_i_]; }\n", e, i, i );
 642                   }
 643                |  _: {}
 644                }
 645                i++;
 646             }
 647          }
 648       |  TYCONty(RECORDtycon (labs,_), tys):
 649          {  Ids l; Tys t;
 650             for (l = labs, t = tys; l && t; l = l->#2, t = t->#2) {
 651                match (t->#1)
 652                {  TYCONty(ARRAYtycon (e as (! NOexp)), _):
 653                   {  pr ("%^for (_i_ = (%e) - 1; _i_ >= 0; _i_--)\n"
 654                          "%^{ %s[_i_] = _x%s[_i_]; }\n", e, l->#1, l->#1 );
 655                   }
 656                |  _: {}
 657                }
 658             }
 659          }
 660       |  TYCONty(ARRAYtycon (e as (! NOexp)), #[ elem_ty ... _ ]):
 661          {  pr ("%^for (_i_ = (%e) - 1; _i_ >= 0; _i_--)"
 662                 "%^{  typedef %t __TYPE__;", e, elem_ty, "");
 663             if (is_array_con)
 664                pr ("%^   new (%S + _i_) __TYPE__ (_x%S[_i_]);\n",
 665                     name, name );
 666             else
 667                pr ("%^   %S[_i_] = _x%S[_i_];\n", name, name);
 668             pr ("%^}\n");
 669          }
 670       |  _: { /* skip */ }
 671       }
 672       pr ("%-%^}\n");
 673    } else {
 674       pr (" {}\n");
 675    }
 676 }
 677
 678 ///////////////////////////////////////////////////////////////////////////////
 679 //
 680 //  Method to generate a C++ class constructor for a datatype
 681 //
 682 ///////////////////////////////////////////////////////////////////////////////
 683 void DatatypeCompiler::gen_datatype_constructor
 684    (Id id, TyVars tyvars, Id name, int unit, int arg, TyOpt opt, Ty ty, Bool def,
 685     TyQual qual)
 686 {
 687    Bool interface_only = def && tyvars == #[] && options.save_space;
 688    Bool is_variable  = qual & QUALvariable;
 689    Id class_name = ((opt & OPTsubclassless) ? "a" : id);
 690    Id cons_name  = ((opt & OPTsubclassless) ? id : mangle(name));
 691
 692    ///////////////////////////////////////////////////////////////////////////
 693    //  Generate a dereference function if the value is represented implicitly
 694    //  within the pointer.
 695    ///////////////////////////////////////////////////////////////////////////
 696    if (opt & OPTunboxed)
 697    {  pr("%^%s%s%t deref_%S(const a_%s * x)",
 698          ((interface_only || ! def) ? "" : "inline "),
 699          (def ? "friend " : ""), ty, "", name, id);
 700       if (interface_only) pr (";\n");
 701       else {
 702          int tag_bits = max_embedded_bits;
 703          for (int i = unit; i >= max_embedded_tags; i >>= 1)
 704              tag_bits++;
 705          pr("%^   { return (%t)((long)x>>(%i+1)); }", ty, "", tag_bits);
 706       }
 707    }
 708
 709    // header
 710    pr ((is_variable ? "%^%s%sa_%s%V * %S ()" : "%^%s%sa_%s%V * %S %b"),
 711        ((interface_only || ! def) ? "" : "inline "),
 712        (def ? "friend " : ""),
 713        id, tyvars, name, ty, name, TYformal);
 714
 715    if (interface_only) {
 716       pr (";\n");
 717    } else {
 718       pr ("%^   { return ");
 719       if (opt & OPTtaggedpointer) pr ("(a_%s*)((unsigned long)(", id);
 720       if (opt & OPTunboxed) {
 721          // Unboxed implementation
 722
 723          int tag_bits = max_embedded_bits;
 724          for (int i = unit; i >= max_embedded_tags; i >>= 1)
 725              tag_bits++;
 726
 727          pr ("(a_%s *)(((unsigned long)%b<<(%i+1))|%i)",
 728              id, ty, name, TYactual, tag_bits, (1 << tag_bits));
 729       } else {
 730          // Boxed implementation
 731          pr ("new ");
 732          if (is_array_constructor(name))
 733             pr ("(sizeof(%s_%S%V)+sizeof(%t)*_x_len_) ",
 734                 class_name, cons_name, tyvars, ty, "");
 735          pr ((is_variable ? "%s_%S%V" : "%s_%S%V %b"),
 736              class_name, cons_name, tyvars, ty, name, TYactual);
 737       }
 738       if (opt & OPTtaggedpointer) pr (")|a_%s%V::tag_%S)",id,tyvars,name);
 739       pr ("; }\n");
 740    }
 741
 742    // generate extra constructors for array-style datatype constructors
 743    if (is_array_constructor(name))
 744    {  Tys params = #[];
 745       Ids labels = #[];
 746       for (int i = 1; i <= options.max_vector_len; i++)
 747       {
 748          params = #[ ty ... params ];
 749          labels = append(labels,#[ index_of(i-1) ]);
 750          // header
 751          pr ("%^%s%sa_%s%V * %S ",
 752              ((interface_only || ! def) ? "" : "inline "),
 753              (def ? "friend " : ""),
 754              id, tyvars, name);
 755          pr ("%b", mkrecordty(labels,params,false), mangle(name), TYformal);
 756
 757          if (interface_only) {
 758             pr (";\n");
 759          } else {
 760             if (i > 0)
 761             {  pr ("%^   { %t_tmp_[%i];", ty, "", i);
 762                for (int j = 0; j < i; j++)
 763                   pr("%^     _tmp_[%i] = _x_%i;", j, j);
 764                pr ("%^     return ");
 765             } else {
 766                pr ("%^   { return ");
 767             }
 768             if (opt & OPTtaggedpointer) pr ("(a_%s*)((unsigned long)(", id);
 769             // Boxed implementation
 770             pr ("new ");
 771             if (is_array_constructor(name))
 772                pr ("(sizeof(%s_%S%V)+sizeof(%t)*%i) ",
 773                    class_name, cons_name, tyvars, ty, "", i);
 774             pr ("%s_%S%V (%i,%s)", class_name, cons_name, tyvars, i,
 775                  (i > 0 ? "_tmp_" : "0"));
 776             if (opt & OPTtaggedpointer) pr (")|a_%s%V::tag_%S)",id,tyvars,name);
 777             pr (";%^   }\n");
 778          }
 779       }
 780    }
 781 }
 782
 783 ///////////////////////////////////////////////////////////////////////////////
 784 //
 785 //  Method to generate a C++ class destructor for a datatype
 786 //
 787 ///////////////////////////////////////////////////////////////////////////////
 788 void DatatypeCompiler::gen_class_destructor
 789    (Id id, TyVars tyvars, Id name, Ty ty, TyQual qual, TyOpt opt, Bool def)
 790 {
 791    if ((qual & QUALvirtualdestr) || (name && is_array_constructor(name)))
 792    {
 793       Bool interface_only = def && tyvars == #[] && options.save_space;
 794       Id class_name = ((opt & OPTsubclassless) || name == 0 ? "a" : id);
 795       Id cons_name  = ((opt & OPTsubclassless) || name == 0 ? id : mangle(name));
 796
 797       // constructor header
 798       pr ("%^%s%s%s%s%s%s~%s_%S()",
 799           ((interface_only || ! def) ? "" : "inline "),
 800           (((qual & QUALvirtualdestr) && def) ? "virtual " : ""),
 801           (def ? "" : class_name),
 802           (def ? "" : "_"),
 803           (def ? "" : cons_name),
 804           (def ? "" : "::"),
 805           class_name, cons_name
 806          );
 807       if (interface_only)
 808       {  pr (";\n");
 809       } else
 810       {  if (name && is_array_constructor(name))
 811          {  pr ("%^{  for (int _i_ = 0; _i_ < len_; _i_++)"
 812                 "%^   {  typedef %t __TYPE__;"
 813                 "%^      (%S+_i_)->~__TYPE__();"
 814                 "%^   }"
 815                 "%^}\n",
 816                 ty, "", name);
 817          } else
 818          {  pr (" {}\n");
 819          }
 820       }
 821    }
 822 }