gcc config
[prop.git] / prop-src / datagen.pcc.old
blob11c1a43cdd573ccdefaa093c7bbcbee9b5c777c3
1 ///////////////////////////////////////////////////////////////////////////////
2 //
3 //  This file implements the datatype compiler of Prop.
4 //
5 ///////////////////////////////////////////////////////////////////////////////
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"
15 ///////////////////////////////////////////////////////////////////////////////
17 //  Constructor and destructors for datatype compiler
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() {}
30 ///////////////////////////////////////////////////////////////////////////////
32 //  Top level method to map datatype and type definitions into
33 //  a C++ class hierarchy.
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); }
44    //  Generate the class hierarchies
45    {  for_each (DatatypeDef, d, data_defs) gen_class_hierarchy(d); }
47    //  Compile the pattern laws
48    gen_law_defs(law_defs);
51 ///////////////////////////////////////////////////////////////////////////////
53 //  Method to generate a forward datatype definitions
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    }   
81 ///////////////////////////////////////////////////////////////////////////////
83 //  Print a forward class definition for variant types.
85 ///////////////////////////////////////////////////////////////////////////////
86 void DatatypeCompiler::gen_forward_class_def(Id id, TyVars tyvars, TyQual qual)
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");
100 ///////////////////////////////////////////////////////////////////////////////
102 //  Method to map unit constructors as enum's.
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");
132 ///////////////////////////////////////////////////////////////////////////////
134 //  Method to generate forward class definitions for 
135 //  a datatype with arguments.
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");
160 ///////////////////////////////////////////////////////////////////////////////
162 //  Method to generate a forward type definition
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    }
177 ///////////////////////////////////////////////////////////////////////////////
179 //  Method to generate the class hierarchy
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               }
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               }
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    }
238 ///////////////////////////////////////////////////////////////////////////////
240 //  Print a subclass
242 ///////////////////////////////////////////////////////////////////////////////
243 void DatatypeCompiler::pr_subclass(Bool& subclass, Id name)
244 {  pr (subclass ? ", " : " : ");
245    pr ("public %s",name);
246    subclass = true;
249 ///////////////////////////////////////////////////////////////////////////////
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.
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;
264 ///////////////////////////////////////////////////////////////////////////////
266 //  Method to generate the base class
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;
275    pr ("%^%/%^// Base class for datatype '%s%V'%^%/%^", id, tyvars);
276    if (tyvars) pr ("%H%+%^", tyvars);
277    pr ("class a_%s", id);
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    } 
294    pr (" {\n%^public:%+");
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    }
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    }
318    gen_untagging_functions   (id, tyvars, unit, arg, qualifiers, opt);
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    }
341    if (qualifiers & QUALrelation)
342       pr ("%^static  RelTag relation_tag;"
343           "%^virtual RelTag get_tag() const;\n");
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);
349    pr ("%&",body);
351    pr ("%-%^};\n\n");
352    if (tyvars) pr ("%-");
354    return subclass;
357 ///////////////////////////////////////////////////////////////////////////////
359 //  Method to generate the untagging functions of a class
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 " : "";
367    ///////////////////////////////////////////////////////////////////////////
368    // Generate untagger.
369    ///////////////////////////////////////////////////////////////////////////
370    if ((opt & OPTtagless) == 0) 
371       pr ("%^inline int untag() const { return _tag_; }\n");
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");
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    }
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");
422 ///////////////////////////////////////////////////////////////////////////////
424 //  Method to generate the downcasting functions of a class
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       );
437    Cons var_cons = NOcons;
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    }
455 ///////////////////////////////////////////////////////////////////////////////
457 //  Method to generate a subclass class
459 ///////////////////////////////////////////////////////////////////////////////
460 void DatatypeCompiler::gen_subclass
461    (Id id, TyVars tyvars, int unit, int arg, TyOpt opt, TyQual qual, Cons term)
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);
479          // constructor for class
480          gen_class_constructor(id,tyvars,name,unit,arg,opt,ty,true,cons_qual);
482          // generate datatype constructor
483          gen_datatype_constructor(id,tyvars,name,unit,arg,opt | my_opt,ty,true,cons_qual);
485          // destructor for class
486          gen_class_destructor(id,tyvars,name,ty,qual,opt | my_opt,true);
488          // optional methods
489          gen_class_interface(id,tyvars,name,qual,opt,cons_qual);
491          if (body) pr ("%^%&", body);
492          pr ("%-%^};\n\n"); 
493          if (tyvars) pr("%-");
494       }
495    |  _: { /* skip */ }
496    }
499 ///////////////////////////////////////////////////////////////////////////////
501 //  Method to generate the class interface functions.
503 ///////////////////////////////////////////////////////////////////////////////
504 void DatatypeCompiler::gen_class_interface
505    (Id id, TyVars tyvars, Id name, TyQual qual, TyOpt opt, TyQual cons_qual)
507    Id class_name = ((opt & OPTsubclassless) ? "a" : id); 
508    Id cons_name  = ((opt & OPTsubclassless) ? id : mangle(name)); 
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    }
520    if (cons_qual & QUALvariable)
521    {  pr ("%^%/" 
522           "%^// Method for logical variable manipulation"
523           "%^%/"
524           "%^inline void uninstantiate() { %s = this; }\n", cons_name);
525    }
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          );
538       Bool need_default_constructor = (opt & OPTsubclassless) || name;
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    }
560 ///////////////////////////////////////////////////////////////////////////////
562 //  Method to generate a C++ class constructor for a datatype
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)); 
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);
583    if (interface_only) { pr (";\n"); return; }
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    }
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    } 
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    }
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    }
678 ///////////////////////////////////////////////////////////////////////////////
680 //  Method to generate a C++ class constructor for a datatype
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)); 
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    }
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
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    }
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    }
783 ///////////////////////////////////////////////////////////////////////////////
785 //  Method to generate a C++ class destructor for a datatype
787 ///////////////////////////////////////////////////////////////////////////////
788 void DatatypeCompiler::gen_class_destructor
789    (Id id, TyVars tyvars, Id name, Ty ty, TyQual qual, TyOpt opt, Bool def)
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)); 
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    }