src/lens.c

   1 /*
   2  * lens.c:
   3  *
   4  * Copyright (C) 2007-2011 David Lutterkort
   5  *
   6  * This library is free software; you can redistribute it and/or
   7  * modify it under the terms of the GNU Lesser General Public
   8  * License as published by the Free Software Foundation; either
   9  * version 2.1 of the License, or (at your option) any later version.
  10  *
  11  * This library is distributed in the hope that it will be useful,
  12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14  * Lesser General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU Lesser General Public
  17  * License along with this library; if not, write to the Free Software
  18  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA
  19  *
  20  * Author: David Lutterkort <dlutter@redhat.com>
  21  */
  22
  23 #include <config.h>
  24 #include <stddef.h>
  25
  26 #include "lens.h"
  27 #include "memory.h"
  28 #include "errcode.h"
  29 #include "internal.h"
  30
  31 /* This enum must be kept in sync with type_offs and ntypes */
  32 enum lens_type {
  33     CTYPE, ATYPE, KTYPE, VTYPE
  34 };
  35
  36 static const int const type_offs[] = {
  37     offsetof(struct lens, ctype),
  38     offsetof(struct lens, atype),
  39     offsetof(struct lens, ktype),
  40     offsetof(struct lens, vtype)
  41 };
  42 static const int ntypes = sizeof(type_offs)/sizeof(type_offs[0]);
  43
  44 static const char *lens_type_names[] =
  45     { "ctype", "atype", "ktype", "vtype" };
  46
  47 #define ltype(lns, t) *((struct regexp **) ((char *) lns + type_offs[t]))
  48
  49 static struct value * typecheck_union(struct info *,
  50                                       struct lens *l1, struct lens *l2);
  51 static struct value *typecheck_concat(struct info *,
  52                                       struct lens *l1, struct lens *l2);
  53 static struct value *typecheck_square(struct info *,
  54                                       struct lens *l1, struct lens *l2);
  55 static struct value *typecheck_iter(struct info *info, struct lens *l);
  56 static struct value *typecheck_maybe(struct info *info, struct lens *l);
  57
  58 /* Lens names for pretty printing */
  59 /* keep order in sync with enum type */
  60 static const char *const tags[] = {
  61     "del", "store", "value", "key", "label", "seq", "counter",
  62     "concat", "union",
  63     "subtree", "star", "maybe", "rec", "square"
  64 };
  65
  66 #define ltag(lens) (tags[lens->tag - L_DEL])
  67
  68 static const struct string digits_string = {
  69     .ref = REF_MAX, .str = (char *) "[0123456789]+"
  70 };
  71 static const struct string *const digits_pat = &digits_string;
  72
  73 char *format_lens(struct lens *l) {
  74     char *inf = format_info(l->info);
  75     char *result;
  76
  77     xasprintf(&result, "%s[%s]%s", tags[l->tag - L_DEL], inf,
  78               l->recursive ? "R" : "r");
  79     free(inf);
  80     return result;
  81 }
  82
  83 #define BUG_LENS_TAG(lns)  bug_lens_tag(lns, __FILE__, __LINE__)
  84
  85 static void bug_lens_tag(struct lens *lens, const char *file, int lineno) {
  86     char *s = format_lens(lens);
  87
  88     if (lens != NULL && lens->info != NULL && lens->info->error != NULL) {
  89         bug_on(lens->info->error, file, lineno, "Unexpected lens tag %s", s);
  90     } else {
  91         /* We are really screwed */
  92         assert(0);
  93     }
  94     free(s);
  95     return;
  96 }
  97
  98 /* Construct a finite automaton from REGEXP and return it in *FA.
  99  *
 100  * Return NULL if REGEXP is valid, if the regexp REGEXP has syntax errors,
 101  * return an exception.
 102  */
 103 static struct value *str_to_fa(struct info *info, const char *pattern,
 104                                struct fa **fa, int nocase) {
 105     int error;
 106     struct value *exn = NULL;
 107     size_t re_err_len;
 108     char *re_str = NULL, *re_err = NULL;
 109
 110     *fa = NULL;
 111     error = fa_compile(pattern, strlen(pattern), fa);
 112     if (error == REG_NOERROR) {
 113         if (nocase) {
 114             error = fa_nocase(*fa);
 115             ERR_NOMEM(error < 0, info);
 116         }
 117         return NULL;
 118     }
 119
 120     re_str = escape(pattern, -1, RX_ESCAPES);
 121     ERR_NOMEM(re_str == NULL, info);
 122
 123     exn = make_exn_value(info, "Invalid regular expression /%s/", re_str);
 124
 125     re_err_len = regerror(error, NULL, NULL, 0);
 126     error = ALLOC_N(re_err, re_err_len);
 127     ERR_NOMEM(error < 0, info);
 128
 129     regerror(error, NULL, re_err, re_err_len);
 130     exn_printf_line(exn, "%s", re_err);
 131
 132  done:
 133     free(re_str);
 134     free(re_err);
 135     return exn;
 136  error:
 137     fa_free(*fa);
 138     *fa = NULL;
 139     exn = info->error->exn;
 140     goto done;
 141 }
 142
 143 static struct value *regexp_to_fa(struct regexp *regexp, struct fa **fa) {
 144     return str_to_fa(regexp->info, regexp->pattern->str, fa, regexp->nocase);
 145 }
 146
 147 static struct lens *make_lens(enum lens_tag tag, struct info *info) {
 148     struct lens *lens;
 149     make_ref(lens);
 150     lens->tag = tag;
 151     lens->info = info;
 152
 153     return lens;
 154 }
 155
 156 static struct lens *make_lens_unop(enum lens_tag tag, struct info *info,
 157                                   struct lens *child) {
 158     struct lens *lens = make_lens(tag, info);
 159     lens->child = child;
 160     lens->value = child->value;
 161     lens->key = child->key;
 162     return lens;
 163 }
 164
 165 typedef struct regexp *regexp_combinator(struct info *, int, struct regexp **);
 166
 167 static struct lens *make_lens_binop(enum lens_tag tag, struct info *info,
 168                                     struct lens *l1, struct lens *l2,
 169                                     regexp_combinator *combinator) {
 170     struct lens *lens = make_lens(tag, info);
 171     int n1 = (l1->tag == tag) ? l1->nchildren : 1;
 172     struct regexp **types = NULL;
 173
 174     if (lens == NULL)
 175         goto error;
 176
 177     lens->nchildren = n1;
 178     lens->nchildren += (l2->tag == tag) ? l2->nchildren : 1;
 179
 180     lens->recursive = l1->recursive || l2->recursive;
 181     lens->rec_internal = l1->rec_internal || l2->rec_internal;
 182
 183     if (ALLOC_N(lens->children, lens->nchildren) < 0) {
 184         lens->nchildren = 0;
 185         goto error;
 186     }
 187
 188     if (l1->tag == tag) {
 189         for (int i=0; i < l1->nchildren; i++)
 190             lens->children[i] = ref(l1->children[i]);
 191         unref(l1, lens);
 192     } else {
 193         lens->children[0] = l1;
 194     }
 195
 196     if (l2->tag == tag) {
 197         for (int i=0; i < l2->nchildren; i++)
 198             lens->children[n1 + i] = ref(l2->children[i]);
 199         unref(l2, lens);
 200     } else {
 201         lens->children[n1] = l2;
 202     }
 203
 204     for (int i=0; i < lens->nchildren; i++) {
 205         lens->value = lens->value || lens->children[i]->value;
 206         lens->key = lens->key || lens->children[i]->key;
 207     }
 208
 209     if (ALLOC_N(types, lens->nchildren) < 0)
 210         goto error;
 211
 212     if (! lens->rec_internal) {
 213         /* Inside a recursive lens, we assign types with lns_check_rec
 214          * once we know the entire lens */
 215         for (int t=0; t < ntypes; t++) {
 216             if (lens->recursive && t == CTYPE)
 217                 continue;
 218             for (int i=0; i < lens->nchildren; i++)
 219                 types[i] = ltype(lens->children[i], t);
 220             ltype(lens, t) = (*combinator)(info, lens->nchildren, types);
 221         }
 222     }
 223     FREE(types);
 224
 225     for (int i=0; i < lens->nchildren; i++)
 226         ensure(tag != lens->children[i]->tag, lens->info);
 227
 228     return lens;
 229  error:
 230     unref(lens, lens);
 231     FREE(types);
 232     return NULL;
 233 }
 234
 235 static struct value *make_lens_value(struct lens *lens) {
 236     struct value *v;
 237     v = make_value(V_LENS, ref(lens->info));
 238     v->lens = lens;
 239     return v;
 240 }
 241
 242 struct value *lns_make_union(struct info *info,
 243                              struct lens *l1, struct lens *l2, int check) {
 244     struct lens *lens = NULL;
 245     int consumes_value = l1->consumes_value && l2->consumes_value;
 246     int recursive = l1->recursive || l2->recursive;
 247     int ctype_nullable = l1->ctype_nullable || l2->ctype_nullable;
 248
 249     if (check) {
 250         struct value *exn = typecheck_union(info, l1, l2);
 251         if (exn != NULL)
 252             return exn;
 253     }
 254
 255     lens = make_lens_binop(L_UNION, info, l1, l2, regexp_union_n);
 256     lens->consumes_value = consumes_value;
 257     if (! recursive)
 258         lens->ctype_nullable = ctype_nullable;
 259     return make_lens_value(lens);
 260 }
 261
 262 struct value *lns_make_concat(struct info *info,
 263                               struct lens *l1, struct lens *l2, int check) {
 264     struct lens *lens = NULL;
 265     int consumes_value = l1->consumes_value || l2->consumes_value;
 266     int recursive = l1->recursive || l2->recursive;
 267     int ctype_nullable = l1->ctype_nullable && l2->ctype_nullable;
 268
 269     if (check) {
 270         struct value *exn = typecheck_concat(info, l1, l2);
 271         if (exn != NULL)
 272             return exn;
 273     }
 274     if (l1->value && l2->value) {
 275         return make_exn_value(info, "Multiple stores in concat");
 276     }
 277     if (l1->key && l2->key) {
 278         return make_exn_value(info, "Multiple keys/labels in concat");
 279     }
 280
 281     lens = make_lens_binop(L_CONCAT, info, l1, l2, regexp_concat_n);
 282     lens->consumes_value = consumes_value;
 283     if (! recursive)
 284         lens->ctype_nullable = ctype_nullable;
 285     return make_lens_value(lens);
 286 }
 287
 288 static struct regexp *subtree_atype(struct info *info,
 289                                     struct regexp *ktype,
 290                                     struct regexp *vtype) {
 291     const char *kpat = (ktype == NULL) ? ENC_NULL : ktype->pattern->str;
 292     const char *vpat = (vtype == NULL) ? ENC_NULL : vtype->pattern->str;
 293     char *pat;
 294     struct regexp *result = NULL;
 295     char *ks = NULL, *vs = NULL;
 296     int nocase;
 297
 298     if (ktype != NULL && vtype != NULL && ktype->nocase != vtype->nocase) {
 299         ks = regexp_expand_nocase(ktype);
 300         vs = regexp_expand_nocase(vtype);
 301         ERR_NOMEM(ks == NULL || vs == NULL, info);
 302         if (asprintf(&pat, "(%s)%s(%s)%s", ks, ENC_EQ, vs, ENC_SLASH) < 0)
 303             ERR_NOMEM(true, info);
 304         nocase = 0;
 305     } else {
 306         if (asprintf(&pat, "(%s)%s(%s)%s", kpat, ENC_EQ, vpat, ENC_SLASH) < 0)
 307             ERR_NOMEM(pat == NULL, info);
 308
 309         nocase = 0;
 310         if (ktype != NULL)
 311             nocase = ktype->nocase;
 312         else if (vtype != NULL)
 313             nocase = vtype->nocase;
 314     }
 315     result = make_regexp(info, pat, nocase);
 316  error:
 317     free(ks);
 318     free(vs);
 319     return result;
 320 }
 321
 322 /*
 323  * A subtree lens l1 = [ l ]
 324  *
 325  * Types are assigned as follows:
 326  *
 327  * l1->ctype = l->ctype
 328  * l1->atype = encode(l->ktype, l->vtype)
 329  * l1->ktype = NULL
 330  * l1->vtype = NULL
 331  */
 332 struct value *lns_make_subtree(struct info *info, struct lens *l) {
 333     struct lens *lens;
 334
 335     lens = make_lens_unop(L_SUBTREE, info, l);
 336     lens->ctype = ref(l->ctype);
 337     if (! l->recursive)
 338         lens->atype = subtree_atype(info, l->ktype, l->vtype);
 339     lens->value = lens->key = 0;
 340     lens->recursive = l->recursive;
 341     lens->rec_internal = l->rec_internal;
 342     if (! l->recursive)
 343         lens->ctype_nullable = l->ctype_nullable;
 344     return make_lens_value(lens);
 345 }
 346
 347 struct value *lns_make_star(struct info *info, struct lens *l, int check) {
 348     struct lens *lens;
 349
 350     if (check) {
 351         struct value *exn = typecheck_iter(info, l);
 352         if (exn != NULL)
 353             return exn;
 354     }
 355     if (l->value) {
 356         return make_exn_value(info, "Multiple stores in iteration");
 357     }
 358     if (l->key) {
 359         return make_exn_value(info, "Multiple keys/labels in iteration");
 360     }
 361
 362     lens = make_lens_unop(L_STAR, info, l);
 363     for (int t = 0; t < ntypes; t++) {
 364         ltype(lens, t) = regexp_iter(info, ltype(l, t), 0, -1);
 365     }
 366     lens->recursive = l->recursive;
 367     lens->rec_internal = l->rec_internal;
 368     lens->ctype_nullable = 1;
 369     return make_lens_value(lens);
 370 }
 371
 372 struct value *lns_make_plus(struct info *info, struct lens *l, int check) {
 373     struct value *star, *conc;
 374
 375     star = lns_make_star(info, l, check);
 376     if (EXN(star))
 377         return star;
 378
 379     conc = lns_make_concat(ref(info), ref(l), ref(star->lens), check);
 380     unref(star, value);
 381     return conc;
 382 }
 383
 384 struct value *lns_make_maybe(struct info *info, struct lens *l, int check) {
 385     struct lens *lens;
 386
 387     if (check) {
 388         struct value *exn = typecheck_maybe(info, l);
 389         if (exn != NULL)
 390             return exn;
 391     }
 392     lens = make_lens_unop(L_MAYBE, info, l);
 393     for (int t=0; t < ntypes; t++)
 394         ltype(lens, t) = regexp_maybe(info, ltype(l, t));
 395     lens->value = l->value;
 396     lens->key = l->key;
 397     lens->recursive = l->recursive;
 398     lens->rec_internal = l->rec_internal;
 399     lens->ctype_nullable = 1;
 400     return make_lens_value(lens);
 401 }
 402
 403 /* The ctype of SQR is a regular approximation of the true ctype of SQR
 404  * at this point. In some situations, for example in processing quoted
 405  * strings this leads to false typecheck errors; to lower the chances
 406  * of these, we try to construct the precise ctype of SQR if the
 407  * language of L1 is finite (and has a small number of words)
 408  */
 409 static void square_precise_type(struct info *info,
 410                                 struct regexp **sqr,
 411                                 struct regexp *left,
 412                                 struct regexp *body) {
 413
 414     char **words = NULL;
 415     int nwords = 0, r;
 416     struct fa *fa = NULL;
 417     struct value *exn = NULL;
 418     struct regexp **u = NULL, *c[3], *w = NULL;
 419
 420     exn = str_to_fa(info, left->pattern->str, &fa, left->nocase);
 421     if (exn != NULL)
 422         goto error;
 423
 424     nwords = fa_enumerate(fa, 10, &words); /* The limit of 10 is arbitrary */
 425     if (nwords < 0)
 426         goto error;
 427
 428     r = ALLOC_N(u, nwords);
 429     ERR_NOMEM(r < 0, info);
 430
 431     c[1] = body;
 432     for (int i=0; i < nwords; i++) {
 433         w = make_regexp_literal(left->info, words[i]);
 434         ERR_NOMEM(w == NULL, info);
 435         w->nocase = left->nocase;
 436
 437         c[0] = c[2] = w;
 438         u[i] = regexp_concat_n(info, 3, c);
 439
 440         unref(w, regexp);
 441         ERR_NOMEM(u[i] == NULL, info);
 442     }
 443     w = regexp_union_n(info, nwords, u);
 444     if (w != NULL) {
 445         unref(*sqr, regexp);
 446         *sqr = w;
 447         w = NULL;
 448     }
 449
 450  error:
 451     unref(w, regexp);
 452     for (int i=0; i < nwords; i++) {
 453         free(words[i]);
 454         if (u != NULL)
 455             unref(u[i], regexp);
 456     }
 457     free(words);
 458     free(u);
 459     fa_free(fa);
 460     unref(exn, value);
 461 }
 462
 463 /* Build a square lens as
 464  *    left . body . right
 465  * where left and right accepts the same language and
 466  * captured strings must match. The inability to express this with other
 467  * lenses makes the square primitive necessary.
 468  */
 469 struct value * lns_make_square(struct info *info, struct lens *l1,
 470                                struct lens *l2, struct lens *l3, int check) {
 471     struct value *cnt1 = NULL, *cnt2 = NULL, *res = NULL;
 472     struct lens *sqr = NULL;
 473
 474     /* supported types: L_KEY . body . L_DEL or L_DEL . body . L_DEL */
 475     if (l3->tag != L_DEL || (l1->tag != L_DEL && l1->tag != L_KEY))
 476         return make_exn_value(info, "Supported types: (key lns del) or (del lns del)");
 477
 478     res = typecheck_square(info, l1, l3);
 479     if (res != NULL)
 480         goto error;
 481
 482     res = lns_make_concat(ref(info), ref(l1), ref(l2), check);
 483     if (EXN(res))
 484         goto error;
 485     cnt1 = res;
 486     res = lns_make_concat(ref(info), ref(cnt1->lens), ref(l3), check);
 487     if (EXN(res))
 488         goto error;
 489     cnt2 = res;
 490
 491     sqr = make_lens_unop(L_SQUARE, ref(info), ref(cnt2->lens));
 492     ERR_NOMEM(sqr == NULL, info);
 493
 494     for (int t=0; t < ntypes; t++)
 495         ltype(sqr, t) = ref(ltype(cnt2->lens, t));
 496
 497     square_precise_type(info, &(sqr->ctype), l1->ctype, l2->ctype);
 498
 499     sqr->recursive = cnt2->lens->recursive;
 500     sqr->rec_internal = cnt2->lens->rec_internal;
 501     sqr->consumes_value = cnt2->lens->consumes_value;
 502
 503     res = make_lens_value(sqr);
 504     ERR_NOMEM(res == NULL, info);
 505     sqr = NULL;
 506
 507  error:
 508     unref(info, info);
 509     unref(l1, lens);
 510     unref(l2, lens);
 511     unref(l3, lens);
 512     unref(cnt1, value);
 513     unref(cnt2, value);
 514     unref(sqr, lens);
 515     return res;
 516 }
 517
 518 /*
 519  * Lens primitives
 520  */
 521
 522 static struct regexp *make_regexp_from_string(struct info *info,
 523                                               struct string *string) {
 524     struct regexp *r;
 525     make_ref(r);
 526     if (r != NULL) {
 527         r->info = ref(info);
 528         r->pattern = ref(string);
 529         r->nocase = 0;
 530     }
 531     return r;
 532 }
 533
 534 static struct regexp *restrict_regexp(struct regexp *r) {
 535     char *nre = NULL;
 536     struct regexp *result = NULL;
 537     size_t nre_len;
 538     int ret;
 539
 540     ret = fa_restrict_alphabet(r->pattern->str, strlen(r->pattern->str),
 541                                &nre, &nre_len,
 542                                RESERVED_FROM, RESERVED_TO);
 543     ERR_NOMEM(ret == REG_ESPACE || ret < 0, r->info);
 544     BUG_ON(ret != 0, r->info, NULL);
 545     ensure(nre_len == strlen(nre), r->info);
 546
 547     ret = regexp_c_locale(&nre, &nre_len);
 548     ERR_NOMEM(ret < 0, r->info);
 549
 550     result = make_regexp(r->info, nre, r->nocase);
 551     nre = NULL;
 552     BUG_ON(regexp_compile(result) != 0, r->info,
 553            "Could not compile restricted regexp");
 554  done:
 555     free(nre);
 556     return result;
 557  error:
 558     unref(result, regexp);
 559     goto done;
 560 }
 561
 562 struct value *lns_make_prim(enum lens_tag tag, struct info *info,
 563                             struct regexp *regexp, struct string *string) {
 564     struct lens *lens = NULL;
 565     struct value *exn = NULL;
 566     struct fa *fa_slash = NULL;
 567     struct fa *fa_key = NULL;
 568     struct fa *fa_isect = NULL;
 569
 570     /* Typecheck */
 571     if (tag == L_KEY) {
 572         exn = str_to_fa(info, "(.|\n)*/(.|\n)*", &fa_slash, regexp->nocase);
 573         if (exn != NULL)
 574             goto error;
 575
 576         exn = regexp_to_fa(regexp, &fa_key);
 577         if (exn != NULL)
 578             goto error;
 579
 580         fa_isect = fa_intersect(fa_slash, fa_key);
 581         if (! fa_is_basic(fa_isect, FA_EMPTY)) {
 582             exn = make_exn_value(info,
 583                                  "The key regexp /%s/ matches a '/'",
 584                                  regexp->pattern->str);
 585             goto error;
 586         }
 587         fa_free(fa_isect);
 588         fa_free(fa_key);
 589         fa_free(fa_slash);
 590         fa_isect = fa_key = fa_slash = NULL;
 591     } else if (tag == L_LABEL) {
 592         if (strchr(string->str, SEP) != NULL) {
 593             exn = make_exn_value(info,
 594                                  "The label string \"%s\" contains a '/'",
 595                                  string->str);
 596             goto error;
 597         }
 598     } else if (tag == L_DEL && string != NULL) {
 599         int cnt;
 600         const char *dflt = string->str;
 601         cnt = regexp_match(regexp, dflt, strlen(dflt), 0, NULL);
 602         if (cnt != strlen(dflt)) {
 603             char *s = escape(dflt, -1, RX_ESCAPES);
 604             char *r = regexp_escape(regexp);
 605             exn = make_exn_value(info,
 606                    "del: the default value '%s' does not match /%s/",
 607                    s, r);
 608             FREE(s);
 609             FREE(r);
 610             goto error;
 611         }
 612     }
 613
 614     /* Build the actual lens */
 615     lens = make_lens(tag, info);
 616     lens->regexp = regexp;
 617     lens->string = string;
 618     lens->key = (tag == L_KEY || tag == L_LABEL || tag == L_SEQ);
 619     lens->value = (tag == L_STORE || tag == L_VALUE);
 620     lens->consumes_value = (tag == L_STORE || tag == L_VALUE);
 621     lens->atype = regexp_make_empty(info);
 622     /* Set the ctype */
 623     if (tag == L_DEL || tag == L_STORE || tag == L_KEY) {
 624         lens->ctype = ref(regexp);
 625         lens->ctype_nullable = regexp_matches_empty(lens->ctype);
 626     } else if (tag == L_LABEL || tag == L_VALUE
 627                || tag == L_SEQ || tag == L_COUNTER) {
 628         lens->ctype = regexp_make_empty(info);
 629         lens->ctype_nullable = 1;
 630     } else {
 631         BUG_LENS_TAG(lens);
 632         goto error;
 633     }
 634
 635
 636     /* Set the ktype */
 637     if (tag == L_SEQ) {
 638         lens->ktype =
 639             make_regexp_from_string(info, (struct string *) digits_pat);
 640         if (lens->ktype == NULL)
 641             goto error;
 642     } else if (tag == L_KEY) {
 643         lens->ktype = restrict_regexp(lens->regexp);
 644     } else if (tag == L_LABEL) {
 645         lens->ktype = make_regexp_literal(info, lens->string->str);
 646         if (lens->ktype == NULL)
 647             goto error;
 648     }
 649
 650     /* Set the vtype */
 651     if (tag == L_STORE) {
 652         lens->vtype = restrict_regexp(lens->regexp);
 653     } else if (tag == L_VALUE) {
 654         lens->vtype = make_regexp_literal(info, lens->string->str);
 655     }
 656
 657     return make_lens_value(lens);
 658  error:
 659     fa_free(fa_isect);
 660     fa_free(fa_key);
 661     fa_free(fa_slash);
 662     return exn;
 663 }
 664
 665 /*
 666  * Typechecking of lenses
 667  */
 668 static struct value *disjoint_check(struct info *info, bool is_get,
 669                                     struct regexp *r1, struct regexp *r2) {
 670     struct fa *fa1 = NULL;
 671     struct fa *fa2 = NULL;
 672     struct fa *fa = NULL;
 673     struct value *exn = NULL;
 674     const char *const msg = is_get ? "union.get" : "tree union.put";
 675
 676     if (r1 == NULL || r2 == NULL)
 677         return NULL;
 678
 679     exn = regexp_to_fa(r1, &fa1);
 680     if (exn != NULL)
 681         goto done;
 682
 683     exn = regexp_to_fa(r2, &fa2);
 684     if (exn != NULL)
 685         goto done;
 686
 687     fa = fa_intersect(fa1, fa2);
 688     if (! fa_is_basic(fa, FA_EMPTY)) {
 689         size_t xmpl_len;
 690         char *xmpl;
 691         fa_example(fa, &xmpl, &xmpl_len);
 692         if (! is_get) {
 693             char *fmt = enc_format(xmpl, xmpl_len);
 694             if (fmt != NULL) {
 695                 FREE(xmpl);
 696                 xmpl = fmt;
 697             }
 698         }
 699         exn = make_exn_value(ref(info),
 700                              "overlapping lenses in %s", msg);
 701
 702         if (is_get)
 703             exn_printf_line(exn, "Example matched by both: '%s'", xmpl);
 704         else
 705             exn_printf_line(exn, "Example matched by both: %s", xmpl);
 706         free(xmpl);
 707     }
 708
 709  done:
 710     fa_free(fa);
 711     fa_free(fa1);
 712     fa_free(fa2);
 713
 714     return exn;
 715 }
 716
 717 static struct value *typecheck_union(struct info *info,
 718                                      struct lens *l1, struct lens *l2) {
 719     struct value *exn = NULL;
 720
 721     exn = disjoint_check(info, true, l1->ctype, l2->ctype);
 722     if (exn == NULL) {
 723         exn = disjoint_check(info, false, l1->atype, l2->atype);
 724     }
 725     if (exn != NULL) {
 726         char *fi = format_info(l1->info);
 727         exn_printf_line(exn, "First lens: %s", fi);
 728         free(fi);
 729
 730         fi = format_info(l2->info);
 731         exn_printf_line(exn, "Second lens: %s", fi);
 732         free(fi);
 733     }
 734     return exn;
 735 }
 736
 737 static struct value *
 738 ambig_check(struct info *info, struct fa *fa1, struct fa *fa2,
 739             enum lens_type typ,  struct lens *l1, struct lens *l2,
 740             const char *msg, bool iterated) {
 741     char *upv, *pv, *v;
 742     size_t upv_len;
 743     struct value *exn = NULL;
 744     int r;
 745
 746     r = fa_ambig_example(fa1, fa2, &upv, &upv_len, &pv, &v);
 747     if (r < 0) {
 748         exn = make_exn_value(ref(info), "not enough memory");
 749         if (exn != NULL) {
 750             return exn;
 751         } else {
 752             ERR_REPORT(info, AUG_ENOMEM, NULL);
 753             return info->error->exn;
 754         }
 755     }
 756
 757     if (upv != NULL) {
 758         char *e_u, *e_up, *e_upv, *e_pv, *e_v;
 759         char *s1, *s2;
 760
 761         if (typ == ATYPE) {
 762             e_u = enc_format(upv, pv - upv);
 763             e_up = enc_format(upv, v - upv);
 764             e_upv = enc_format(upv, upv_len);
 765             e_pv = enc_format(pv, strlen(pv));
 766             e_v = enc_format(v, strlen(v));
 767             lns_format_atype(l1, &s1);
 768             lns_format_atype(l2, &s2);
 769         } else {
 770             e_u = escape(upv, pv - upv, RX_ESCAPES);
 771             e_up = escape(upv, v - upv, RX_ESCAPES);
 772             e_upv = escape(upv, -1, RX_ESCAPES);
 773             e_pv = escape(pv, -1, RX_ESCAPES);
 774             e_v = escape(v, -1, RX_ESCAPES);
 775             s1 = regexp_escape(ltype(l1, typ));
 776             s2 = regexp_escape(ltype(l2, typ));
 777         }
 778         exn = make_exn_value(ref(info), "%s", msg);
 779         if (iterated) {
 780             exn_printf_line(exn, "  Iterated regexp: /%s/", s1);
 781         } else {
 782             exn_printf_line(exn, "  First regexp: /%s/", s1);
 783             exn_printf_line(exn, "  Second regexp: /%s/", s2);
 784         }
 785         exn_printf_line(exn, "  '%s' can be split into", e_upv);
 786         exn_printf_line(exn, "  '%s|=|%s'\n", e_u, e_pv);
 787         exn_printf_line(exn, " and");
 788         exn_printf_line(exn, "  '%s|=|%s'\n", e_up, e_v);
 789         free(e_u);
 790         free(e_up);
 791         free(e_upv);
 792         free(e_pv);
 793         free(e_v);
 794         free(s1);
 795         free(s2);
 796     }
 797     free(upv);
 798     return exn;
 799 }
 800
 801 static struct value *
 802 ambig_concat_check(struct info *info, const char *msg,
 803                    enum lens_type typ, struct lens *l1, struct lens *l2) {
 804     struct fa *fa1 = NULL;
 805     struct fa *fa2 = NULL;
 806     struct value *result = NULL;
 807     struct regexp *r1 = ltype(l1, typ);
 808     struct regexp *r2 = ltype(l2, typ);
 809
 810     if (r1 == NULL || r2 == NULL)
 811         return NULL;
 812
 813     result = regexp_to_fa(r1, &fa1);
 814     if (result != NULL)
 815         goto done;
 816
 817     result = regexp_to_fa(r2, &fa2);
 818     if (result != NULL)
 819         goto done;
 820
 821     result = ambig_check(info, fa1, fa2, typ, l1, l2, msg, false);
 822  done:
 823     fa_free(fa1);
 824     fa_free(fa2);
 825     return result;
 826 }
 827
 828 static struct value *typecheck_concat(struct info *info,
 829                                       struct lens *l1, struct lens *l2) {
 830     struct value *result = NULL;
 831
 832     result = ambig_concat_check(info, "ambiguous concatenation",
 833                                 CTYPE, l1, l2);
 834     if (result == NULL) {
 835         result = ambig_concat_check(info, "ambiguous tree concatenation",
 836                                     ATYPE, l1, l2);
 837     }
 838     if (result != NULL) {
 839         char *fi = format_info(l1->info);
 840         exn_printf_line(result, "First lens: %s", fi);
 841         free(fi);
 842         fi = format_info(l2->info);
 843         exn_printf_line(result, "Second lens: %s", fi);
 844         free(fi);
 845     }
 846     return result;
 847 }
 848
 849 static struct value *make_exn_square(struct info *info, struct lens *l1,
 850                                      struct lens *l2, const char *msg) {
 851
 852     char *fi;
 853     struct value *exn = make_exn_value(ref(info), "%s",
 854             "Inconsistency in lens square");
 855     exn_printf_line(exn, "%s", msg);
 856     fi = format_info(l1->info);
 857     exn_printf_line(exn, "Left lens: %s", fi);
 858     free(fi);
 859     fi = format_info(l2->info);
 860     exn_printf_line(exn, "Right lens: %s", fi);
 861     free(fi);
 862     return exn;
 863 }
 864
 865 static struct value *typecheck_square(struct info *info, struct lens *l1,
 866                                       struct lens *l2) {
 867     int r;
 868     struct value *exn = NULL;
 869     struct fa *fa1 = NULL, *fa2 = NULL;
 870     struct regexp *r1 = ltype(l1, CTYPE);
 871     struct regexp *r2 = ltype(l2, CTYPE);
 872
 873     if (r1 == NULL || r2 == NULL)
 874         return NULL;
 875
 876     exn = regexp_to_fa(r1, &fa1);
 877     if (exn != NULL)
 878         goto done;
 879
 880     exn = regexp_to_fa(r2, &fa2);
 881     if (exn != NULL)
 882         goto done;
 883
 884     r = fa_equals(fa1, fa2);
 885
 886     if (r < 0) {
 887         exn = make_exn_value(ref(info), "not enough memory");
 888         if (exn != NULL) {
 889             return exn;
 890         } else {
 891             ERR_REPORT(info, AUG_ENOMEM, NULL);
 892             return info->error->exn;;
 893         }
 894     }
 895
 896     if (r == 0) {
 897         exn = make_exn_square(info, l1, l2,
 898                 "Left and right lenses must accept the same language");
 899         goto done;
 900     }
 901
 902     /* check del create consistency */
 903     if (l1->tag == L_DEL && l2->tag == L_DEL) {
 904         if (!STREQ(l1->string->str, l2->string->str)) {
 905             exn = make_exn_square(info, l1, l2,
 906                     "Left and right lenses must have the same default value");
 907             goto done;
 908         }
 909     }
 910
 911  done:
 912     fa_free(fa1);
 913     fa_free(fa2);
 914     return exn;
 915 }
 916
 917 static struct value *
 918 ambig_iter_check(struct info *info, const char *msg,
 919                  enum lens_type typ, struct lens *l) {
 920     struct fa *fas = NULL, *fa = NULL;
 921     struct value *result = NULL;
 922     struct regexp *r = ltype(l, typ);
 923
 924     if (r == NULL)
 925         return NULL;
 926
 927     result = regexp_to_fa(r, &fa);
 928     if (result != NULL)
 929         goto done;
 930
 931     fas = fa_iter(fa, 0, -1);
 932
 933     result = ambig_check(info, fa, fas, typ, l, l, msg, true);
 934
 935  done:
 936     fa_free(fa);
 937     fa_free(fas);
 938     return result;
 939 }
 940
 941 static struct value *typecheck_iter(struct info *info, struct lens *l) {
 942     struct value *result = NULL;
 943
 944     result = ambig_iter_check(info, "ambiguous iteration", CTYPE, l);
 945     if (result == NULL) {
 946         result = ambig_iter_check(info, "ambiguous tree iteration", ATYPE, l);
 947     }
 948     if (result != NULL) {
 949         char *fi = format_info(l->info);
 950         exn_printf_line(result, "Iterated lens: %s", fi);
 951         free(fi);
 952     }
 953     return result;
 954 }
 955
 956 static struct value *typecheck_maybe(struct info *info, struct lens *l) {
 957     /* Check (r)? as (<e>|r) where <e> is the empty language */
 958     struct value *exn = NULL;
 959
 960     if (l->ctype != NULL && regexp_matches_empty(l->ctype)) {
 961         exn = make_exn_value(ref(info),
 962                 "illegal optional expression: /%s/ matches the empty word",
 963                 l->ctype->pattern->str);
 964     }
 965
 966     /* Typecheck the put direction; the check passes if
 967        (1) the atype does not match the empty string, because we can tell
 968            from looking at tree nodes whether L should be applied or not
 969        (2) L handles a value; with that, we know whether to apply L or not
 970            depending on whether the current node has a non NULL value or not
 971     */
 972     if (exn == NULL && ! l->consumes_value) {
 973         if (l->atype != NULL && regexp_matches_empty(l->atype)) {
 974             exn = make_exn_value(ref(info),
 975                "optional expression matches the empty tree but does not consume a value");
 976         }
 977     }
 978     return exn;
 979 }
 980
 981 void free_lens(struct lens *lens) {
 982     if (lens == NULL)
 983         return;
 984     ensure(lens->ref == 0, lens->info);
 985
 986     if (debugging("lenses"))
 987         dump_lens_tree(lens);
 988     switch (lens->tag) {
 989     case L_DEL:
 990         unref(lens->regexp, regexp);
 991         unref(lens->string, string);
 992         break;
 993     case L_STORE:
 994     case L_KEY:
 995         unref(lens->regexp, regexp);
 996         break;
 997     case L_LABEL:
 998     case L_SEQ:
 999     case L_COUNTER:
1000     case L_VALUE:
1001         unref(lens->string, string);
1002         break;
1003     case L_SUBTREE:
1004     case L_STAR:
1005     case L_MAYBE:
1006     case L_SQUARE:
1007         unref(lens->child, lens);
1008         break;
1009     case L_CONCAT:
1010     case L_UNION:
1011         for (int i=0; i < lens->nchildren; i++)
1012             unref(lens->children[i], lens);
1013         free(lens->children);
1014         break;
1015     case L_REC:
1016         if (!lens->rec_internal) {
1017             unref(lens->body, lens);
1018         }
1019         break;
1020     default:
1021         BUG_LENS_TAG(lens);
1022         break;
1023     }
1024
1025     for (int t=0; t < ntypes; t++)
1026         unref(ltype(lens, t), regexp);
1027
1028     unref(lens->info, info);
1029     jmt_free(lens->jmt);
1030     free(lens);
1031  error:
1032     return;
1033 }
1034
1035 void lens_release(struct lens *lens) {
1036     if (lens == NULL)
1037         return;
1038
1039     for (int t=0; t < ntypes; t++)
1040         regexp_release(ltype(lens, t));
1041
1042     if (lens->tag == L_KEY || lens->tag == L_STORE)
1043         regexp_release(lens->regexp);
1044
1045     if (lens->tag == L_SUBTREE || lens->tag == L_STAR
1046         || lens->tag == L_MAYBE || lens->tag == L_SQUARE) {
1047         lens_release(lens->child);
1048     }
1049
1050     if (lens->tag == L_UNION || lens->tag == L_CONCAT) {
1051         for (int i=0; i < lens->nchildren; i++) {
1052             lens_release(lens->children[i]);
1053         }
1054     }
1055
1056     jmt_free(lens->jmt);
1057     lens->jmt = NULL;
1058 }
1059
1060 /*
1061  * Encoding of tree levels
1062  */
1063 char *enc_format(const char *e, size_t len) {
1064     size_t size = 0;
1065     char *result = NULL, *r;
1066     const char *k = e;
1067
1068     while (*k && k - e < len) {
1069         char *eq,  *slash, *v;
1070         eq = strchr(k, ENC_EQ_CH);
1071         assert(eq != NULL);
1072         slash = strchr(eq, ENC_SLASH_CH);
1073         assert(slash != NULL);
1074         v = eq + 1;
1075
1076         size += 6;     /* Surrounding braces */
1077         if (k != eq)
1078             size += 1 + (eq - k) + 1;
1079         if (v != slash)
1080             size += 4 + (slash - v) + 1;
1081         k = slash + 1;
1082     }
1083     if (ALLOC_N(result, size + 1) < 0)
1084         return NULL;
1085
1086     k = e;
1087     r = result;
1088     while (*k && k - e < len) {
1089         char *eq,  *slash, *v;
1090         eq = strchr(k, ENC_EQ_CH);
1091         slash = strchr(eq, ENC_SLASH_CH);
1092         assert(eq != NULL && slash != NULL);
1093         v = eq + 1;
1094
1095         r = stpcpy(r, " { ");
1096         if (k != eq) {
1097             r = stpcpy(r, "\"");
1098             r = stpncpy(r, k, eq - k);
1099             r = stpcpy(r, "\"");
1100         }
1101         if (v != slash) {
1102             r = stpcpy (r, " = \"");
1103             r = stpncpy(r, v, slash - v);
1104             r = stpcpy(r, "\"");
1105         }
1106         r = stpcpy(r, " }");
1107         k = slash + 1;
1108     }
1109     return result;
1110 }
1111
1112 static int lns_format_subtree_atype(struct lens *l, char **buf) {
1113     char *k = NULL, *v = NULL;
1114     const struct regexp *ktype = l->child->ktype;
1115     const struct regexp *vtype = l->child->vtype;
1116     int r, result = -1;
1117
1118     if (ktype != NULL) {
1119         k = regexp_escape(ktype);
1120         if (k == NULL)
1121             goto done;
1122     }
1123     if (vtype != NULL) {
1124         v = regexp_escape(vtype);
1125         if (v == NULL)
1126             goto done;
1127         if (k == NULL)
1128             r = xasprintf(buf, "{ = /%s/ }", k, v);
1129         else
1130             r = xasprintf(buf, "{ /%s/ = /%s/ }", k, v);
1131     } else {
1132         if (k == NULL)
1133             r = xasprintf(buf, "{ }", k);
1134         else
1135             r = xasprintf(buf, "{ /%s/ }", k);
1136     }
1137     if (r < 0)
1138         goto done;
1139
1140     result = 0;
1141  done:
1142     FREE(v);
1143     FREE(k);
1144     return result;
1145 }
1146
1147 static int lns_format_rep_atype(struct lens *l, char **buf, char quant) {
1148     char *a = NULL;
1149     int r, result = -1;
1150
1151     r = lns_format_atype(l->child, &a);
1152     if (r < 0)
1153         goto done;
1154     if (strlen(a) == 0) {
1155         *buf = a;
1156         a = NULL;
1157         result = 0;
1158         goto done;
1159     }
1160
1161     if (l->child->tag == L_CONCAT || l->child->tag == L_UNION)
1162         r = xasprintf(buf, "(%s)%c", a, quant);
1163     else
1164         r = xasprintf(buf, "%s%c", a, quant);
1165
1166     if (r < 0)
1167         goto done;
1168
1169     result = 0;
1170  done:
1171     FREE(a);
1172     return result;
1173 }
1174
1175 static int lns_format_concat_atype(struct lens *l, char **buf) {
1176     char **c = NULL, *s = NULL, *p;
1177     int r, result = -1;
1178     size_t len = 0, nconc = 0;
1179
1180     if (ALLOC_N(c, l->nchildren) < 0)
1181         goto done;
1182
1183     for (int i=0; i < l->nchildren; i++) {
1184         r = lns_format_atype(l->children[i], c+i);
1185         if (r < 0)
1186             goto done;
1187         len += strlen(c[i]) + 2;
1188         if (strlen(c[i]) > 0)
1189             nconc += 1;
1190         if (l->children[i]->tag == L_UNION)
1191             len += 2;
1192     }
1193
1194     if (ALLOC_N(s, len+1) < 0)
1195         goto done;
1196     p = s;
1197     for (int i=0; i < l->nchildren; i++) {
1198         bool needs_parens = nconc > 1 && l->children[i]->tag == L_UNION;
1199         if (strlen(c[i]) == 0)
1200             continue;
1201         if (needs_parens)
1202             *p++ = '(';
1203         p = stpcpy(p, c[i]);
1204         if (needs_parens)
1205             *p++ = ')';
1206     }
1207
1208     *buf = s;
1209     s = NULL;
1210     result = 0;
1211  done:
1212     if (c != NULL)
1213         for (int i=0; i < l->nchildren; i++)
1214             FREE(c[i]);
1215     FREE(c);
1216     FREE(s);
1217     return result;
1218 }
1219
1220 static int lns_format_union_atype(struct lens *l, char **buf) {
1221     char **c = NULL, *s = NULL, *p;
1222     int r, result = -1;
1223     size_t len = 0;
1224
1225     if (ALLOC_N(c, l->nchildren) < 0)
1226         goto done;
1227
1228     for (int i=0; i < l->nchildren; i++) {
1229         r = lns_format_atype(l->children[i], c+i);
1230         if (r < 0)
1231             goto done;
1232         len += strlen(c[i]) + 2;
1233     }
1234     len += l->nchildren - 1;
1235
1236     if (ALLOC_N(s, len+1) < 0)
1237         goto done;
1238
1239     p = s;
1240     for (int i=0; i < l->nchildren; i++) {
1241         if (i > 0)
1242             p = stpcpy(p, " | ");
1243         if (strlen(c[i]) == 0)
1244             p = stpcpy(p, "()");
1245         else
1246             p = stpcpy(p, c[i]);
1247     }
1248     *buf = s;
1249     s = NULL;
1250     result = 0;
1251  done:
1252     if (c != NULL)
1253         for (int i=0; i < l->nchildren; i++)
1254             FREE(c[i]);
1255     FREE(c);
1256     FREE(s);
1257     return result;
1258 }
1259
1260 static int lns_format_rec_atype(struct lens *l, char **buf) {
1261     int r;
1262
1263     if (l->rec_internal) {
1264         *buf = strdup("<<rec>>");
1265         return (*buf == NULL) ? -1 : 0;
1266     }
1267
1268     char *c = NULL;
1269     r = lns_format_atype(l->body, &c);
1270     if (r < 0)
1271         return -1;
1272     r = xasprintf(buf, "<<rec:%s>>", c);
1273     free(c);
1274     return (r < 0) ? -1 : 0;
1275 }
1276
1277 int lns_format_atype(struct lens *l, char **buf) {
1278     *buf = NULL;
1279
1280     switch(l->tag) {
1281     case L_DEL:
1282     case L_STORE:
1283     case L_KEY:
1284     case L_LABEL:
1285     case L_VALUE:
1286     case L_SEQ:
1287     case L_COUNTER:
1288         *buf = strdup("");
1289         return (*buf == NULL) ? -1 : 0;
1290         break;
1291     case L_SUBTREE:
1292         return lns_format_subtree_atype(l, buf);
1293         break;
1294     case L_STAR:
1295         return lns_format_rep_atype(l, buf, '*');
1296         break;
1297     case L_MAYBE:
1298         return lns_format_rep_atype(l, buf, '?');
1299         break;
1300     case L_CONCAT:
1301         return lns_format_concat_atype(l, buf);
1302         break;
1303     case L_UNION:
1304         return lns_format_union_atype(l, buf);
1305         break;
1306     case L_REC:
1307         return lns_format_rec_atype(l, buf);
1308         break;
1309     case L_SQUARE:
1310         return lns_format_concat_atype(l->child, buf);
1311         break;
1312     default:
1313         BUG_LENS_TAG(l);
1314         break;
1315     };
1316     return -1;
1317 }
1318
1319 /*
1320  * Recursive lenses
1321  */
1322 struct value *lns_make_rec(struct info *info) {
1323     struct lens *l = make_lens(L_REC, info);
1324     l->recursive = 1;
1325     l->rec_internal = 1;
1326
1327     return make_lens_value(l);
1328 }
1329
1330 /* Transform a recursive lens into a recursive transition network
1331  *
1332  * First, we transform the lens into context free grammar, considering any
1333  * nonrecursive lens as a terminal
1334  *
1335  * cfg: lens -> nonterminal -> production list
1336  *
1337  * cfg(primitive, N) -> N := regexp(primitive)
1338  * cfg(l1 . l2, N)   -> N := N1 . N2 + cfg(l1, N1) + cfg(l2, N2)
1339  * cfg(l1 | l2, N)   -> N := N1 | N2 + cfg(l1, N1) + cfg(l2, N2)
1340  * cfg(l*, N)        -> N := N . N' | eps + cfg(l, N')
1341  * cfg([ l ], N)     -> N := N' + cfg(l, N')
1342  *
1343  * We use the lenses as nonterminals themselves; this also means that our
1344  * productions are normalized such that the RHS is either a terminal
1345  * (regexp) or entirely consists of nonterminals
1346  *
1347  * In a few places, we need to know that a nonterminal corresponds to a
1348  * subtree combinator ([ l ]); this is the main reason that the rule (cfg[
1349  * l ], N) introduces a useless production N := N'.
1350  *
1351  * Computing the types for a recursive lens r is (fairly) straightforward,
1352  * given the above grammar, which we convert to an automaton following
1353  * http://arxiv.org/abs/cs/9910022; the only complication arises from the
1354  * subtree combinator, since it can be used in recursive lenses to
1355  * construct trees of arbitrary depth, but we need to approximate the types
1356  * of r in a way that fits with our top-down tree automaton in put.c.
1357  *
1358  * To handle subtree combinators, remember that the type rules for a lens
1359  * m = [ l ] are:
1360  *
1361  *   m.ktype = NULL
1362  *   m.vtype = NULL
1363  *   m.ctype = l.ctype
1364  *   m.atype = enc(l.ktype, l.vtype)
1365  *     ( enc is a function regexp -> regexp -> regexp)
1366  *
1367  * We compute types for r by modifying its automaton according to
1368  * Nederhof's paper and reducing it to a regular expression of lenses. This
1369  * has to happen in the following steps:
1370  *   r.ktype : approximate by using [ .. ].ktype = NULL
1371  *   r.vtype : same as r.ktype
1372  *   r.ctype : approximate by treating [ l ] as l
1373  *   r.atype : approximate by using r.ktype and r.vtype from above
1374  *             in lens expressions [ f(r) ]
1375  */
1376
1377 /* Transitions go to a state and are labeled with a lens. For epsilon
1378  * transitions, lens may be NULL. When lens is a simple (nonrecursive
1379  * lens), PROD will be NULL. When we modify the automaton to splice
1380  * nonterminals in, we remember the production for the nonterminal in PROD.
1381  */
1382 struct trans {
1383     struct state  *to;
1384     struct lens   *lens;
1385     struct regexp *re;
1386 };
1387
1388 struct state {
1389     struct state  *next;   /* Linked list for memory management */
1390     size_t         ntrans;
1391     struct trans  *trans;
1392 };
1393
1394 /* Productions for lens LENS. Start state START and end state END. If we
1395    start with START, END is the only accepting state. */
1396 struct prod {
1397     struct lens  *lens;
1398     struct state *start;
1399     struct state *end;
1400 };
1401
1402 /* A recursive transition network used to compute regular approximations
1403  * to the types */
1404 struct rtn {
1405     struct info *info;
1406     size_t        nprod;
1407     struct prod **prod;
1408     struct state *states;  /* Linked list through next of all states in all
1409                               prods; the states for each production are on
1410                               the part of the list from prod->start to
1411                               prod->end */
1412     struct value *exn;
1413     enum lens_type lens_type;
1414     unsigned int check : 1;
1415 };
1416
1417 #define RTN_BAIL(rtn) if ((rtn)->exn != NULL ||                     \
1418                           (rtn)->info->error->code != AUG_NOERROR)  \
1419                          goto error;
1420
1421 static void free_prod(struct prod *prod) {
1422     if (prod == NULL)
1423         return;
1424     unref(prod->lens, lens);
1425     free(prod);
1426 }
1427
1428 static void free_rtn(struct rtn *rtn) {
1429     if (rtn == NULL)
1430         return;
1431     for (int i=0; i < rtn->nprod; i++)
1432         free_prod(rtn->prod[i]);
1433     free(rtn->prod);
1434     list_for_each(s, rtn->states) {
1435         for (int i=0; i < s->ntrans; i++) {
1436             unref(s->trans[i].lens, lens);
1437             unref(s->trans[i].re, regexp);
1438         }
1439         free(s->trans);
1440     }
1441     list_free(rtn->states);
1442     unref(rtn->info, info);
1443     unref(rtn->exn, value);
1444     free(rtn);
1445 }
1446
1447 static struct state *add_state(struct prod *prod) {
1448     struct state *result = NULL;
1449     int r;
1450
1451     r = ALLOC(result);
1452     ERR_NOMEM(r < 0, prod->lens->info);
1453
1454     list_cons(prod->start->next, result);
1455  error:
1456     return result;
1457 }
1458
1459 static struct trans *add_trans(struct rtn *rtn, struct state *state,
1460                                struct state *to, struct lens *l) {
1461     int r;
1462     struct trans *result = NULL;
1463
1464     for (int i=0; i < state->ntrans; i++)
1465         if (state->trans[i].to == to && state->trans[i].lens == l)
1466             return state->trans + i;
1467
1468     r = REALLOC_N(state->trans, state->ntrans+1);
1469     ERR_NOMEM(r < 0, rtn->info);
1470
1471     result = state->trans + state->ntrans;
1472     state->ntrans += 1;
1473
1474     MEMZERO(result, 1);
1475     result->to = to;
1476     if (l != NULL) {
1477         result->lens = ref(l);
1478         result->re = ref(ltype(l, rtn->lens_type));
1479     }
1480  error:
1481     return result;
1482 }
1483
1484 static struct prod *make_prod(struct rtn *rtn, struct lens *l) {
1485     struct prod *result = NULL;
1486     int r;
1487
1488     r = ALLOC(result);
1489     ERR_NOMEM(r < 0, l->info);
1490
1491     result->lens = ref(l);
1492     r = ALLOC(result->start);
1493     ERR_NOMEM(r < 0, l->info);
1494
1495     result->end = add_state(result);
1496     ERR_BAIL(l->info);
1497
1498     result->end->next = rtn->states;
1499     rtn->states = result->start;
1500
1501     return result;
1502  error:
1503     free_prod(result);
1504     return NULL;
1505 }
1506
1507 static struct prod *prod_for_lens(struct rtn *rtn, struct lens *l) {
1508     if (l == NULL)
1509         return NULL;
1510     for (int i=0; i < rtn->nprod; i++) {
1511         if (rtn->prod[i]->lens == l)
1512             return rtn->prod[i];
1513     }
1514     return NULL;
1515 }
1516
1517 static void rtn_dot(struct rtn *rtn, const char *stage) {
1518     FILE *fp;
1519     int r = 0;
1520
1521     fp = debug_fopen("rtn_%s_%s.dot", stage, lens_type_names[rtn->lens_type]);
1522     if (fp == NULL)
1523         return;
1524
1525     fprintf(fp, "digraph \"l1\" {\n  rankdir=LR;\n");
1526     list_for_each(s, rtn->states) {
1527         char *label = NULL;
1528         for (int p=0; p < rtn->nprod; p++) {
1529             if (s == rtn->prod[p]->start) {
1530                 r = xasprintf(&label, "s%d", p);
1531             } else if (s == rtn->prod[p]->end) {
1532                 r = xasprintf(&label, "e%d", p);
1533             }
1534             ERR_NOMEM(r < 0, rtn->info);
1535         }
1536         if (label == NULL) {
1537             r = xasprintf(&label, "%p", s);
1538             ERR_NOMEM(r < 0, rtn->info);
1539         }
1540         fprintf(fp, "  n%p [label = \"%s\"];\n", s, label == NULL ? "" : label);
1541         FREE(label);
1542         for (int i=0; i < s->ntrans; i++) {
1543             fprintf(fp, "  n%p -> n%p", s, s->trans[i].to);
1544             if (s->trans[i].re != NULL) {
1545                 label = regexp_escape(s->trans[i].re);
1546                 for (char *t = label; *t; t++)
1547                     if (*t == '\\')
1548                         *t = '~';
1549                 fprintf(fp, " [ label = \"%s\" ]", label);
1550                 FREE(label);
1551             }
1552             fprintf(fp, ";\n");
1553         }
1554     }
1555  error:
1556     fprintf(fp, "}\n");
1557     fclose(fp);
1558 }
1559
1560 /* Add transitions to RTN corresponding to cfg(l, N) */
1561 static void rtn_rules(struct rtn *rtn, struct lens *l) {
1562     if (! l->recursive)
1563         return;
1564
1565     struct prod *prod = prod_for_lens(rtn, l);
1566     if (prod != NULL)
1567         return;
1568
1569     int r = REALLOC_N(rtn->prod, rtn->nprod+1);
1570     ERR_NOMEM(r < 0, l->info);
1571
1572     prod =  make_prod(rtn, l);
1573     rtn->prod[rtn->nprod] = prod;
1574     RTN_BAIL(rtn);
1575     rtn->nprod += 1;
1576
1577     struct state *start = prod->start;
1578
1579     switch (l->tag) {
1580     case L_UNION:
1581         /* cfg(l1|..|ln, N) -> N := N1 | N2 | ... | Nn */
1582         for (int i=0; i < l->nchildren; i++) {
1583             add_trans(rtn, start, prod->end, l->children[i]);
1584             RTN_BAIL(rtn);
1585             rtn_rules(rtn, l->children[i]);
1586             RTN_BAIL(rtn);
1587         }
1588         break;
1589     case L_CONCAT:
1590         /* cfg(l1 . l2 ... ln, N) -> N := N1 . N2 ... Nn */
1591         for (int i=0; i < l->nchildren-1; i++) {
1592             struct state *s = add_state(prod);
1593             RTN_BAIL(rtn);
1594             add_trans(rtn, start, s, l->children[i]);
1595             RTN_BAIL(rtn);
1596             start = s;
1597             rtn_rules(rtn, l->children[i]);
1598             RTN_BAIL(rtn);
1599         }
1600         {
1601             struct lens *c = l->children[l->nchildren - 1];
1602             add_trans(rtn, start, prod->end, c);
1603             RTN_BAIL(rtn);
1604             rtn_rules(rtn, c);
1605             RTN_BAIL(rtn);
1606         }
1607         break;
1608     case L_STAR: {
1609         /* cfg(l*, N) -> N := N . N' | eps */
1610         struct state *s = add_state(prod);
1611         RTN_BAIL(rtn);
1612         add_trans(rtn, start, s, l);
1613         RTN_BAIL(rtn);
1614         add_trans(rtn, s, prod->end, l->child);
1615         RTN_BAIL(rtn);
1616         add_trans(rtn, start, prod->end, NULL);
1617         RTN_BAIL(rtn);
1618         rtn_rules(rtn, l->child);
1619         RTN_BAIL(rtn);
1620         break;
1621     }
1622     case L_SUBTREE:
1623         switch (rtn->lens_type) {
1624         case KTYPE:
1625         case VTYPE:
1626             /* cfg([ l ], N) -> N := eps */
1627             add_trans(rtn, start, prod->end, NULL);
1628             break;
1629         case CTYPE:
1630             /* cfg([ l ], N) -> N := N' plus cfg(l, N') */
1631             add_trans(rtn, start, prod->end, l->child);
1632             RTN_BAIL(rtn);
1633             rtn_rules(rtn, l->child);
1634             RTN_BAIL(rtn);
1635             break;
1636         case ATYPE: {
1637             /* At this point, we have propagated ktype and vtype */
1638             /* cfg([ l ], N) -> N := enc(l->ktype, l->vtype) */
1639             struct trans *t = add_trans(rtn, start, prod->end, NULL);
1640             RTN_BAIL(rtn);
1641             t->re = subtree_atype(l->info, l->child->ktype, l->child->vtype);
1642             break;
1643         }
1644         default:
1645             BUG_ON(true, rtn->info, "Unexpected lens type %d", rtn->lens_type);
1646             break;
1647         }
1648         break;
1649     case L_MAYBE:
1650         /* cfg(l?, N) -> N := N' | eps plus cfg(l, N') */
1651         add_trans(rtn, start, prod->end, l->child);
1652         RTN_BAIL(rtn);
1653         add_trans(rtn, start, prod->end, NULL);
1654         RTN_BAIL(rtn);
1655         rtn_rules(rtn, l->child);
1656         RTN_BAIL(rtn);
1657         break;
1658     case L_REC:
1659         /* cfg(l, N) -> N := N' plus cfg(l->body, N') */
1660         add_trans(rtn, start, prod->end, l->body);
1661         RTN_BAIL(rtn);
1662         rtn_rules(rtn, l->body);
1663         RTN_BAIL(rtn);
1664         break;
1665     case L_SQUARE:
1666         add_trans(rtn, start, prod->end, l->child);
1667         RTN_BAIL(rtn);
1668         break;
1669     default:
1670         BUG_LENS_TAG(l);
1671         break;
1672     }
1673  error:
1674     return;
1675 }
1676
1677 /* Replace transition t with two epsilon transitions s => p->start and
1678  * p->end => s->trans[i].to where s is the start of t. Instead of adding
1679  * epsilon transitions, we expand the epsilon transitions.
1680  */
1681 static void prod_splice(struct rtn *rtn,
1682                         struct prod *from, struct prod *to, struct trans *t) {
1683
1684     add_trans(rtn, to->end, t->to, NULL);
1685     ERR_BAIL(from->lens->info);
1686     t->to = to->start;
1687     unref(t->re, regexp);
1688
1689  error:
1690     return;
1691 }
1692
1693 static void rtn_splice(struct rtn *rtn, struct prod *prod) {
1694     for (struct state *s = prod->start; s != prod->end; s = s->next) {
1695         for (int i=0; i < s->ntrans; i++) {
1696             struct prod *p = prod_for_lens(rtn, s->trans[i].lens);
1697             if (p != NULL) {
1698                 prod_splice(rtn, prod, p, s->trans+i);
1699                 RTN_BAIL(rtn);
1700             }
1701         }
1702     }
1703  error:
1704     return;
1705 }
1706
1707 static struct rtn *rtn_build(struct lens *rec, enum lens_type lt) {
1708     int r;
1709     struct rtn *rtn;
1710
1711     r = ALLOC(rtn);
1712     ERR_NOMEM(r < 0, rec->info);
1713
1714     rtn->info = ref(rec->info);
1715     rtn->lens_type = lt;
1716
1717     rtn_rules(rtn, rec);
1718     RTN_BAIL(rtn);
1719     if (debugging("cf.approx"))
1720         rtn_dot(rtn, "10-rules");
1721
1722     for (int i=0; i < rtn->nprod; i++) {
1723         rtn_splice(rtn, rtn->prod[i]);
1724         RTN_BAIL(rtn);
1725     }
1726     if (debugging("cf.approx"))
1727         rtn_dot(rtn, "11-splice");
1728
1729  error:
1730     return rtn;
1731 }
1732
1733 /* Compare transitions lexicographically by (to, lens) */
1734 static int trans_to_cmp(const void *v1, const void *v2) {
1735     const struct trans *t1 = v1;
1736     const struct trans *t2 = v2;
1737
1738     if (t1->to != t2->to)
1739         return (t1->to < t2->to) ? -1 : 1;
1740
1741     if (t1->lens == t2->lens)
1742         return 0;
1743     return (t1->lens < t2->lens) ? -1 : 1;
1744 }
1745
1746 /* Collapse a transition S1 -> S -> S2 by adding a transition S1 -> S2 with
1747  * lens R1 . (LOOP)* . R2 | R3 where R3 is the regexp on the possibly
1748  * existing transition S1 -> S2. If LOOP is NULL or R3 does not exist,
1749  * label the transition with a simplified regexp by treating NULL as
1750  * epsilon */
1751 static void collapse_trans(struct rtn *rtn,
1752                            struct state *s1, struct state *s2,
1753                            struct regexp *r1, struct regexp *loop,
1754                            struct regexp *r2) {
1755
1756     struct trans *t = NULL;
1757     struct regexp *r = NULL;
1758
1759     for (int i=0; i < s1->ntrans; i++) {
1760         if (s1->trans[i].to == s2) {
1761             t = s1->trans + i;
1762             break;
1763         }
1764     }
1765
1766     /* Set R = R1 . (LOOP)* . R2, treating NULL's as epsilon */
1767     if (loop == NULL) {
1768         if (r1 == NULL)
1769             r = ref(r2);
1770         else if (r2 == NULL)
1771             r = ref(r1);
1772         else
1773             r = regexp_concat(rtn->info, r1, r2);
1774     } else {
1775         struct regexp *s = regexp_iter(rtn->info, loop, 0, -1);
1776         ERR_NOMEM(s == NULL, rtn->info);
1777         struct regexp *c = NULL;
1778         if (r1 == NULL) {
1779             c = s;
1780             s = NULL;
1781         } else {
1782             c = regexp_concat(rtn->info, r1, s);
1783             unref(s, regexp);
1784             ERR_NOMEM(c == NULL, rtn->info);
1785         }
1786         if (r2 == NULL) {
1787             r = c;
1788             c = NULL;
1789         } else {
1790             r = regexp_concat(rtn->info, c, r2);
1791             unref(c, regexp);
1792             ERR_NOMEM(r == NULL, rtn->info);
1793         }
1794     }
1795
1796     if (t == NULL) {
1797         t = add_trans(rtn, s1, s2, NULL);
1798         ERR_NOMEM(t == NULL, rtn->info);
1799         t->re = r;
1800     } else if (t->re == NULL) {
1801         if (r == NULL || regexp_matches_empty(r))
1802             t->re = r;
1803         else {
1804             t->re = regexp_maybe(rtn->info, r);
1805             unref(r, regexp);
1806             ERR_NOMEM(t->re == NULL, rtn->info);
1807         }
1808     } else if (r == NULL) {
1809         if (!regexp_matches_empty(t->re)) {
1810             r = regexp_maybe(rtn->info, t->re);
1811             unref(t->re, regexp);
1812             t->re = r;
1813             ERR_NOMEM(r == NULL, rtn->info);
1814         }
1815     } else {
1816         struct regexp *u = regexp_union(rtn->info, r, t->re);
1817         unref(r, regexp);
1818         unref(t->re, regexp);
1819         t->re = u;
1820         ERR_NOMEM(u == NULL, rtn->info);
1821     }
1822
1823     return;
1824  error:
1825     rtn->exn = rtn->info->error->exn;
1826     return;
1827 }
1828
1829 /* Reduce the automaton with start state rprod->start and only accepting
1830  * state rprod->end so that we have a single transition rprod->start =>
1831  * rprod->end labelled with the overall approximating regexp for the
1832  * automaton.
1833  *
1834  * This is the same algorithm as fa_as_regexp in fa.c
1835  */
1836 static struct regexp *rtn_reduce(struct rtn *rtn, struct lens *rec) {
1837     struct prod *prod = prod_for_lens(rtn, rec);
1838     int r;
1839
1840     ERR_THROW(prod == NULL, rtn->info, AUG_EINTERNAL,
1841               "No production for recursive lens");
1842
1843     /* Eliminate epsilon transitions and turn transitions between the same
1844      * two states into a regexp union */
1845     list_for_each(s, rtn->states) {
1846         qsort(s->trans, s->ntrans, sizeof(*s->trans), trans_to_cmp);
1847         for (int i=0; i < s->ntrans; i++) {
1848             int j = i+1;
1849             for (;j < s->ntrans && s->trans[i].to == s->trans[j].to;
1850                  j++);
1851             if (j > i+1) {
1852                 struct regexp *u, **v;
1853                 r = ALLOC_N(v, j - i);
1854                 ERR_NOMEM(r < 0, rtn->info);
1855                 for (int k=i; k < j; k++)
1856                     v[k-i] = s->trans[k].re;
1857                 u = regexp_union_n(rtn->info, j - i, v);
1858                 if (u == NULL) {
1859                     // FIXME: The calling convention for regexp_union_n
1860                     // is bad, since we can't distinguish between alloc
1861                     // failure and unioning all NULL's
1862                     for (int k=0; k < j-i; k++)
1863                         if (v[k] != NULL) {
1864                             FREE(v);
1865                             ERR_NOMEM(true, rtn->info);
1866                         }
1867                 }
1868                 FREE(v);
1869                 for (int k=i; k < j; k++) {
1870                     unref(s->trans[k].lens, lens);
1871                     unref(s->trans[k].re, regexp);
1872                 }
1873                 s->trans[i].re = u;
1874                 MEMMOVE(s->trans + (i+1),
1875                         s->trans + j,
1876                         s->ntrans - j);
1877                 s->ntrans -= j - (i + 1);
1878             }
1879         }
1880     }
1881
1882     /* Introduce new start and end states with epsilon transitions to/from
1883      * the old start and end states */
1884     struct state *end = NULL;
1885     struct state *start = NULL;
1886     if (ALLOC(start) < 0 || ALLOC(end) < 0) {
1887         FREE(start);
1888         FREE(end);
1889         ERR_NOMEM(true, rtn->info);
1890     }
1891     list_insert_before(start, prod->start, rtn->states);
1892     end->next = prod->end->next;
1893     prod->end->next = end;
1894
1895     add_trans(rtn, start, prod->start, NULL);
1896     RTN_BAIL(rtn);
1897     add_trans(rtn, prod->end, end, NULL);
1898     RTN_BAIL(rtn);
1899
1900     prod->start = start;
1901     prod->end = end;
1902
1903     /* Eliminate states S (except for INI and FIN) one by one:
1904      *     Let LOOP the regexp for the transition S -> S if it exists, epsilon
1905      *     otherwise.
1906      *     For all S1, S2 different from S with S1 -> S -> S2
1907      *       Let R1 the regexp of S1 -> S
1908      *           R2 the regexp of S -> S2
1909      *           R3 the regexp of S1 -> S2 (or the regexp matching nothing
1910      *                                      if no such transition)
1911      *        set the regexp on the transition S1 -> S2 to
1912      *          R1 . (LOOP)* . R2 | R3 */
1913     // FIXME: This does not go over all states
1914     list_for_each(s, rtn->states) {
1915         if (s == prod->end || s == prod->start)
1916             continue;
1917         struct regexp *loop = NULL;
1918         for (int i=0; i < s->ntrans; i++) {
1919             if (s == s->trans[i].to) {
1920                 ensure(loop == NULL, rtn->info);
1921                 loop = s->trans[i].re;
1922             }
1923         }
1924         list_for_each(s1, rtn->states) {
1925             if (s == s1)
1926                 continue;
1927             for (int t1=0; t1 < s1->ntrans; t1++) {
1928                 if (s == s1->trans[t1].to) {
1929                     for (int t2=0; t2 < s->ntrans; t2++) {
1930                         struct state *s2 = s->trans[t2].to;
1931                         if (s2 == s)
1932                             continue;
1933                         collapse_trans(rtn, s1, s2,
1934                                        s1->trans[t1].re, loop,
1935                                        s->trans[t2].re);
1936                         RTN_BAIL(rtn);
1937                     }
1938                 }
1939             }
1940         }
1941     }
1942
1943     /* Find the overall regexp */
1944     struct regexp *result = NULL;
1945     for (int i=0; i < prod->start->ntrans; i++) {
1946         if (prod->start->trans[i].to == prod->end) {
1947             ensure(result == NULL, rtn->info);
1948             result = ref(prod->start->trans[i].re);
1949         }
1950     }
1951     return result;
1952  error:
1953     return NULL;
1954 }
1955
1956 static void propagate_type(struct lens *l, enum lens_type lt) {
1957     struct regexp **types = NULL;
1958     int r;
1959
1960     if (! l->recursive || ltype(l, lt) != NULL)
1961         return;
1962
1963     switch(l->tag) {
1964     case L_CONCAT:
1965         r = ALLOC_N(types, l->nchildren);
1966         ERR_NOMEM(r < 0, l->info);
1967         for (int i=0; i < l->nchildren; i++) {
1968             propagate_type(l->children[i], lt);
1969             types[i] = ltype(l->children[i], lt);
1970         }
1971         ltype(l, lt) = regexp_concat_n(l->info, l->nchildren, types);
1972         FREE(types);
1973         break;
1974     case L_UNION:
1975         r = ALLOC_N(types, l->nchildren);
1976         ERR_NOMEM(r < 0, l->info);
1977         for (int i=0; i < l->nchildren; i++) {
1978             propagate_type(l->children[i], lt);
1979             types[i] = ltype(l->children[i], lt);
1980         }
1981         ltype(l, lt) = regexp_union_n(l->info, l->nchildren, types);
1982         FREE(types);
1983         break;
1984     case L_SUBTREE:
1985         propagate_type(l->child, lt);
1986         if (lt == ATYPE)
1987             l->atype = subtree_atype(l->info, l->child->ktype, l->child->vtype);
1988         if (lt == CTYPE)
1989             l->ctype = ref(l->child->ctype);
1990         break;
1991     case L_STAR:
1992         propagate_type(l->child, lt);
1993         ltype(l, lt) = regexp_iter(l->info, ltype(l->child, lt), 0, -1);
1994         break;
1995     case L_MAYBE:
1996         propagate_type(l->child, lt);
1997         ltype(l, lt) = regexp_maybe(l->info, ltype(l->child, lt));
1998         break;
1999     case L_REC:
2000         /* Nothing to do */
2001         break;
2002     case L_SQUARE:
2003         propagate_type(l->child, lt);
2004         ltype(l, lt) = ref(ltype(l->child, lt));
2005         break;
2006     default:
2007         BUG_LENS_TAG(l);
2008         break;
2009     }
2010
2011  error:
2012     FREE(types);
2013 }
2014
2015 static struct value *typecheck(struct lens *l, int check);
2016
2017 typedef struct value *typecheck_n_make(struct info *,
2018                                        struct lens *, struct lens *, int);
2019
2020 static struct info *merge_info(struct info *i1, struct info *i2) {
2021     struct info *info;
2022     make_ref(info);
2023     ERR_NOMEM(info == NULL, i1);
2024
2025     info->filename = ref(i1->filename);
2026     info->first_line = i1->first_line;
2027     info->first_column = i1->first_column;
2028     info->last_line    = i2->last_line;
2029     info->last_column  = i2->last_column;
2030     info->error        = i1->error;
2031     return info;
2032
2033  error:
2034     unref(info, info);
2035     return NULL;
2036 }
2037
2038 static struct value *typecheck_n(struct lens *l,
2039                                  typecheck_n_make *make, int check) {
2040     struct value *exn = NULL;
2041     struct lens *acc = NULL;
2042
2043     ensure(l->tag == L_CONCAT || l->tag == L_UNION, l->info);
2044     for (int i=0; i < l->nchildren; i++) {
2045         exn = typecheck(l->children[i], check);
2046         if (exn != NULL)
2047             goto error;
2048     }
2049     acc = ref(l->children[0]);
2050     for (int i=1; i < l->nchildren; i++) {
2051         struct info *info = merge_info(acc->info, l->children[i]->info);
2052         ERR_BAIL(acc->info);
2053         exn = (*make)(info, acc, ref(l->children[i]), check);
2054         if (EXN(exn))
2055             goto error;
2056         ensure(exn->tag == V_LENS, l->info);
2057         acc = ref(exn->lens);
2058         unref(exn, value);
2059     }
2060     l->value = acc->value;
2061     l->key = acc->key;
2062  error:
2063     unref(acc, lens);
2064     return exn;
2065 }
2066
2067 static struct value *typecheck(struct lens *l, int check) {
2068     struct value *exn = NULL;
2069
2070     /* Nonrecursive lenses are typechecked at build time */
2071     if (! l->recursive)
2072         return NULL;
2073
2074     switch(l->tag) {
2075     case L_CONCAT:
2076         exn = typecheck_n(l, lns_make_concat, check);
2077         break;
2078     case L_UNION:
2079         exn = typecheck_n(l, lns_make_union, check);
2080         break;
2081     case L_SUBTREE:
2082     case L_SQUARE:
2083         exn = typecheck(l->child, check);
2084         break;
2085     case L_STAR:
2086         if (check)
2087             exn = typecheck_iter(l->info, l->child);
2088         if (exn == NULL && l->value)
2089             exn = make_exn_value(l->info, "Multiple stores in iteration");
2090         if (exn == NULL && l->key)
2091             exn = make_exn_value(l->info, "Multiple keys/labels in iteration");
2092         break;
2093     case L_MAYBE:
2094         if (check)
2095             exn = typecheck_maybe(l->info, l->child);
2096         l->key = l->child->key;
2097         l->value = l->child->value;
2098         break;
2099     case L_REC:
2100         /* Nothing to do */
2101         break;
2102     default:
2103         BUG_LENS_TAG(l);
2104         break;
2105     }
2106
2107     return exn;
2108 }
2109
2110 static struct value *rtn_approx(struct lens *rec, enum lens_type lt) {
2111     struct rtn *rtn = NULL;
2112     struct value *result = NULL;
2113
2114     rtn = rtn_build(rec, lt);
2115     RTN_BAIL(rtn);
2116     ltype(rec, lt) = rtn_reduce(rtn, rec);
2117     RTN_BAIL(rtn);
2118     if (debugging("cf.approx"))
2119         rtn_dot(rtn, "50-reduce");
2120
2121     propagate_type(rec->body, lt);
2122     ERR_BAIL(rec->info);
2123
2124  done:
2125     free_rtn(rtn);
2126
2127     if (debugging("cf.approx")) {
2128         printf("approx %s  => ", lens_type_names[lt]);
2129         print_regexp(stdout, ltype(rec, lt));
2130         printf("\n");
2131     }
2132
2133     return result;
2134  error:
2135     if (rtn->exn == NULL)
2136         result = rec->info->error->exn;
2137     else
2138         result = ref(rtn->exn);
2139     goto done;
2140 }
2141
2142 static struct value *
2143 exn_multiple_epsilons(struct lens *lens,
2144                       struct lens *l1, struct lens *l2) {
2145     char *fi = NULL;
2146     struct value *exn = NULL;
2147
2148     exn = make_exn_value(ref(lens->info),
2149                          "more than one nullable branch in a union");
2150     fi = format_info(l1->info);
2151     exn_printf_line(exn, "First nullable lens: %s", fi);
2152     FREE(fi);
2153
2154     fi = format_info(l2->info);
2155     exn_printf_line(exn, "Second nullable lens: %s", fi);
2156     FREE(fi);
2157
2158     return exn;
2159 }
2160
2161 /* Update lens->ctype_nullable and return 1 if there was a change,
2162  * 0 if there was none */
2163 static int ctype_nullable(struct lens *lens, struct value **exn) {
2164     int nullable = 0;
2165     int ret = 0;
2166     struct lens *null_lens = NULL;
2167
2168     if (! lens->recursive)
2169         return 0;
2170
2171     switch(lens->tag) {
2172     case L_CONCAT:
2173         nullable = 1;
2174         for (int i=0; i < lens->nchildren; i++) {
2175             if (ctype_nullable(lens->children[i], exn))
2176                 ret = 1;
2177             if (! lens->children[i]->ctype_nullable)
2178                 nullable = 0;
2179         }
2180         break;
2181     case L_UNION:
2182         for (int i=0; i < lens->nchildren; i++) {
2183             if (ctype_nullable(lens->children[i], exn))
2184                 ret = 1;
2185             if (lens->children[i]->ctype_nullable) {
2186                 if (nullable) {
2187                     *exn = exn_multiple_epsilons(lens, null_lens,
2188                                                  lens->children[i]);
2189                     return 0;
2190                 }
2191                 nullable = 1;
2192                 null_lens = lens->children[i];
2193             }
2194         }
2195         break;
2196     case L_SUBTREE:
2197     case L_SQUARE:
2198         ret = ctype_nullable(lens->child, exn);
2199         nullable = lens->child->ctype_nullable;
2200         break;
2201     case L_STAR:
2202     case L_MAYBE:
2203         nullable = 1;
2204         break;
2205     case L_REC:
2206         nullable = lens->body->ctype_nullable;
2207         break;
2208     default:
2209         BUG_LENS_TAG(lens);
2210         break;
2211     }
2212     if (*exn != NULL)
2213         return 0;
2214     if (nullable != lens->ctype_nullable) {
2215         ret = 1;
2216         lens->ctype_nullable = nullable;
2217     }
2218     return ret;
2219 }
2220
2221 struct value *lns_check_rec(struct info *info,
2222                             struct lens *body, struct lens *rec,
2223                             int check) {
2224     /* The types in the order of approximation */
2225     static const enum lens_type types[] = { KTYPE, VTYPE, ATYPE };
2226     struct value *result = NULL;
2227
2228     ensure(rec->tag == L_REC, info);
2229     ensure(rec->rec_internal, info);
2230
2231     /* The user might have written down a regular lens with 'let rec' */
2232     if (! body->recursive) {
2233         result = make_lens_value(ref(body));
2234         ERR_NOMEM(result == NULL, info);
2235         return result;
2236     }
2237
2238     /* To help memory management, we avoid the cycle inherent ina recursive
2239      * lens by using two instances of an L_REC lens. One is marked with
2240      * rec_internal, and used inside the body of the lens. The other is the
2241      * "toplevel" which receives external references.
2242      *
2243      * The internal instance of the recursive lens is REC, the external one
2244      * is TOP, constructed below
2245      */
2246     rec->body = body;                          /* REC does not own BODY */
2247
2248     for (int i=0; i < ARRAY_CARDINALITY(types); i++) {
2249         result = rtn_approx(rec, types[i]);
2250         ERR_BAIL(info);
2251     }
2252
2253     if (rec->atype == NULL) {
2254         result = make_exn_value(ref(rec->info),
2255         "recursive lens generates the empty language for its %s",
2256          rec->ctype == NULL ? "ctype" : "atype");
2257         goto error;
2258     }
2259
2260     rec->key = rec->body->key;
2261     rec->value = rec->body->value;
2262     rec->consumes_value = rec->body->consumes_value;
2263
2264     while(ctype_nullable(rec->body, &result));
2265     if (result != NULL)
2266         goto error;
2267     rec->ctype_nullable = rec->body->ctype_nullable;
2268
2269     result = typecheck(rec->body, check);
2270     if (result != NULL)
2271         goto error;
2272
2273     result = lns_make_rec(ref(rec->info));
2274     struct lens *top = result->lens;
2275     for (int t=0; t < ntypes; t++)
2276         ltype(top, t) = ref(ltype(rec, t));
2277     top->value = rec->value;
2278     top->key = rec->key;
2279     top->consumes_value = rec->consumes_value;
2280     top->ctype_nullable = rec->ctype_nullable;
2281     top->body = ref(body);
2282     top->alias = rec;
2283     top->rec_internal = 0;
2284     rec->alias = top;
2285
2286     top->jmt = jmt_build(top);
2287     ERR_BAIL(info);
2288
2289     return result;
2290  error:
2291     if (result != NULL && result->tag != V_EXN)
2292         unref(result, value);
2293     if (result == NULL)
2294         result = info->error->exn;
2295     return result;
2296 }
2297
2298 #if ENABLE_DEBUG
2299 void dump_lens_tree(struct lens *lens){
2300     static int count = 0;
2301     FILE *fp;
2302
2303     fp = debug_fopen("lens_%02d_%s.dot", count++, ltag(lens));
2304     if (fp == NULL)
2305         return;
2306
2307     fprintf(fp, "digraph \"%s\" {\n", "lens");
2308     dump_lens(fp, lens);
2309     fprintf(fp, "}\n");
2310
2311     fclose(fp);
2312 }
2313
2314 void dump_lens(FILE *out, struct lens *lens){
2315     int i = 0;
2316     struct regexp *re;
2317
2318     fprintf(out, "\"%p\" [ shape = box, label = \"%s\\n", lens, ltag(lens));
2319
2320     for (int t=0; t < ntypes; t++) {
2321         re = ltype(lens, t);
2322         if (re == NULL)
2323             continue;
2324         fprintf(out, "%s=",lens_type_names[t]);
2325         print_regexp(out, re);
2326         fprintf(out, "\\n");
2327     }
2328
2329     fprintf(out, "recursive=%x\\n", lens->recursive);
2330     fprintf(out, "rec_internal=%x\\n", lens->rec_internal);
2331     fprintf(out, "consumes_value=%x\\n", lens->consumes_value);
2332     fprintf(out, "ctype_nullable=%x\\n", lens->ctype_nullable);
2333     fprintf(out, "\"];\n");
2334     switch(lens->tag){
2335     case L_DEL:
2336         break;
2337     case L_STORE:
2338         break;
2339     case L_VALUE:
2340         break;
2341     case L_KEY:
2342         break;
2343     case L_LABEL:
2344         break;
2345     case L_SEQ:
2346         break;
2347     case L_COUNTER:
2348         break;
2349     case L_CONCAT:
2350         for(i = 0; i<lens->nchildren;i++){
2351             fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->children[i]);
2352             dump_lens(out, lens->children[i]);
2353         }
2354         break;
2355     case L_UNION:
2356         for(i = 0; i<lens->nchildren;i++){
2357             fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->children[i]);
2358             dump_lens(out, lens->children[i]);
2359         }
2360         break;
2361     case L_SUBTREE:
2362         fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->child);
2363         dump_lens(out, lens->child);
2364         break;
2365     case L_STAR:
2366         fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->child);
2367         dump_lens(out, lens->child);
2368
2369         break;
2370     case L_MAYBE:
2371         fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->child);
2372         dump_lens(out, lens->child);
2373
2374         break;
2375     case L_REC:
2376         if (lens->rec_internal == 0){
2377             fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->child);
2378             dump_lens(out, lens->body);
2379         }
2380         break;
2381     case L_SQUARE:
2382         fprintf(out, "\"%p\" -> \"%p\"\n", lens, lens->child);
2383         dump_lens(out, lens->child);
2384         break;
2385     default:
2386         fprintf(out, "ERROR\n");
2387         break;
2388     }
2389 }
2390 #endif
2391
2392 /*
2393  * Local variables:
2394  *  indent-tabs-mode: nil
2395  *  c-indent-level: 4
2396  *  c-basic-offset: 4
2397  *  tab-width: 4
2398  * End:
2399  */