src/language/data-io/data-list.c

   1 /* PSPP - computes sample statistics.
   2    Copyright (C) 1997-9, 2000, 2006 Free Software Foundation, Inc.
   3    Written by Ben Pfaff <blp@gnu.org>.
   4
   5    This program is free software; you can redistribute it and/or
   6    modify it under the terms of the GNU General Public License as
   7    published by the Free Software Foundation; either version 2 of the
   8    License, or (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful, but
  11    WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13    General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18    02110-1301, USA. */
  19
  20 #include <config.h>
  21 #include <language/data-io/data-list.h>
  22 #include <libpspp/message.h>
  23 #include <ctype.h>
  24 #include <float.h>
  25 #include <stdio.h>
  26 #include <stdlib.h>
  27 #include <libpspp/alloc.h>
  28 #include <data/case.h>
  29 #include <language/command.h>
  30 #include <libpspp/compiler.h>
  31 #include <data/data-in.h>
  32 #include <libpspp/debug-print.h>
  33 #include <language/data-io/data-reader.h>
  34 #include <data/dictionary.h>
  35 #include <libpspp/message.h>
  36 #include <language/data-io/file-handle.h>
  37 #include <data/format.h>
  38 #include <language/lexer/lexer.h>
  39 #include <libpspp/misc.h>
  40 #include <data/settings.h>
  41 #include <libpspp/str.h>
  42 #include <output/table.h>
  43 #include <data/variable.h>
  44 #include <procedure.h>
  45
  46 #include "data-list.h"
  47
  48 #include "gettext.h"
  49 #define _(msgid) gettext (msgid)
  50 \f
  51 /* Utility function. */
  52
  53 /* FIXME: Either REPEATING DATA must be the last transformation, or we
  54    must multiplex the transformations that follow (i.e., perform them
  55    for every case that we produce from a repetition instance).
  56    Currently we do neither.  We should do one or the other. */
  57
  58 /* Describes how to parse one variable. */
  59 struct dls_var_spec
  60   {
  61     struct dls_var_spec *next;  /* Next specification in list. */
  62
  63     /* Both free and fixed formats. */
  64     struct fmt_spec input;      /* Input format of this field. */
  65     struct variable *v;         /* Associated variable.  Used only in
  66                                    parsing.  Not safe later. */
  67     int fv;                     /* First value in case. */
  68
  69     /* Fixed format only. */
  70     int rec;                    /* Record number (1-based). */
  71     int fc, lc;                 /* Column numbers in record. */
  72
  73     /* Free format only. */
  74     char name[LONG_NAME_LEN + 1]; /* Name of variable. */
  75   };
  76
  77 /* Constants for DATA LIST type. */
  78 /* Must match table in cmd_data_list(). */
  79 enum
  80   {
  81     DLS_FIXED,
  82     DLS_FREE,
  83     DLS_LIST
  84   };
  85
  86 /* DATA LIST private data structure. */
  87 struct data_list_pgm
  88   {
  89     struct dls_var_spec *first, *last;  /* Variable parsing specifications. */
  90     struct dfm_reader *reader;  /* Data file reader. */
  91
  92     int type;                   /* A DLS_* constant. */
  93     struct variable *end;       /* Variable specified on END subcommand. */
  94     int rec_cnt;                /* Number of records. */
  95     size_t case_size;           /* Case size in bytes. */
  96     char *delims;               /* Delimiters if any; not null-terminated. */
  97     size_t delim_cnt;           /* Number of delimiter, or 0 for spaces. */
  98   };
  99
 100 static const struct case_source_class data_list_source_class;
 101
 102 static int parse_fixed (struct data_list_pgm *);
 103 static int parse_free (struct dls_var_spec **, struct dls_var_spec **);
 104 static void dump_fixed_table (const struct dls_var_spec *,
 105                               const struct file_handle *, int rec_cnt);
 106 static void dump_free_table (const struct data_list_pgm *,
 107                              const struct file_handle *);
 108 static void destroy_dls_var_spec (struct dls_var_spec *);
 109 static trns_free_func data_list_trns_free;
 110 static trns_proc_func data_list_trns_proc;
 111
 112 /* Message title for REPEATING DATA. */
 113 #define RPD_ERR "REPEATING DATA: "
 114
 115 int
 116 cmd_data_list (void)
 117 {
 118   struct data_list_pgm *dls;
 119   int table = -1;                /* Print table if nonzero, -1=undecided. */
 120   struct file_handle *fh = fh_inline_file ();
 121
 122   if (!case_source_is_complex (vfm_source))
 123     discard_variables ();
 124
 125   dls = xmalloc (sizeof *dls);
 126   dls->reader = NULL;
 127   dls->type = -1;
 128   dls->end = NULL;
 129   dls->rec_cnt = 0;
 130   dls->delims = NULL;
 131   dls->delim_cnt = 0;
 132   dls->first = dls->last = NULL;
 133
 134   while (token != '/')
 135     {
 136       if (lex_match_id ("FILE"))
 137         {
 138           lex_match ('=');
 139           fh = fh_parse (FH_REF_FILE | FH_REF_INLINE);
 140           if (fh == NULL)
 141             goto error;
 142           if (case_source_is_class (vfm_source, &file_type_source_class)
 143               && fh != fh_get_default_handle ())
 144             {
 145               msg (SE, _("DATA LIST must use the same file "
 146                          "as the enclosing FILE TYPE."));
 147               goto error;
 148             }
 149         }
 150       else if (lex_match_id ("RECORDS"))
 151         {
 152           lex_match ('=');
 153           lex_match ('(');
 154           if (!lex_force_int ())
 155             goto error;
 156           dls->rec_cnt = lex_integer ();
 157           lex_get ();
 158           lex_match (')');
 159         }
 160       else if (lex_match_id ("END"))
 161         {
 162           if (dls->end)
 163             {
 164               msg (SE, _("The END subcommand may only be specified once."));
 165               goto error;
 166             }
 167
 168           lex_match ('=');
 169           if (!lex_force_id ())
 170             goto error;
 171           dls->end = dict_lookup_var (default_dict, tokid);
 172           if (!dls->end)
 173             dls->end = dict_create_var_assert (default_dict, tokid, 0);
 174           lex_get ();
 175         }
 176       else if (token == T_ID)
 177         {
 178           if (lex_match_id ("NOTABLE"))
 179             table = 0;
 180           else if (lex_match_id ("TABLE"))
 181             table = 1;
 182           else
 183             {
 184               int type;
 185               if (lex_match_id ("FIXED"))
 186                 type = DLS_FIXED;
 187               else if (lex_match_id ("FREE"))
 188                 type = DLS_FREE;
 189               else if (lex_match_id ("LIST"))
 190                 type = DLS_LIST;
 191               else
 192                 {
 193                   lex_error (NULL);
 194                   goto error;
 195                 }
 196
 197               if (dls->type != -1)
 198                 {
 199                   msg (SE, _("Only one of FIXED, FREE, or LIST may "
 200                              "be specified."));
 201                   goto error;
 202                 }
 203               dls->type = type;
 204
 205               if ((dls->type == DLS_FREE || dls->type == DLS_LIST)
 206                   && lex_match ('('))
 207                 {
 208                   while (!lex_match (')'))
 209                     {
 210                       int delim;
 211
 212                       if (lex_match_id ("TAB"))
 213                         delim = '\t';
 214                       else if (token == T_STRING && tokstr.length == 1)
 215                         {
 216                           delim = tokstr.string[0];
 217                           lex_get();
 218                         }
 219                       else
 220                         {
 221                           lex_error (NULL);
 222                           goto error;
 223                         }
 224
 225                       dls->delims = xrealloc (dls->delims, dls->delim_cnt + 1);
 226                       dls->delims[dls->delim_cnt++] = delim;
 227
 228                       lex_match (',');
 229                     }
 230                 }
 231             }
 232         }
 233       else
 234         {
 235           lex_error (NULL);
 236           goto error;
 237         }
 238     }
 239
 240   dls->case_size = dict_get_case_size (default_dict);
 241   fh_set_default_handle (fh);
 242
 243   if (dls->type == -1)
 244     dls->type = DLS_FIXED;
 245
 246   if (table == -1)
 247     {
 248       if (dls->type == DLS_FREE)
 249         table = 0;
 250       else
 251         table = 1;
 252     }
 253
 254   if (dls->type == DLS_FIXED)
 255     {
 256       if (!parse_fixed (dls))
 257         goto error;
 258       if (table)
 259         dump_fixed_table (dls->first, fh, dls->rec_cnt);
 260     }
 261   else
 262     {
 263       if (!parse_free (&dls->first, &dls->last))
 264         goto error;
 265       if (table)
 266         dump_free_table (dls, fh);
 267     }
 268
 269   dls->reader = dfm_open_reader (fh);
 270   if (dls->reader == NULL)
 271     goto error;
 272
 273   if (vfm_source != NULL)
 274     add_transformation (data_list_trns_proc, data_list_trns_free, dls);
 275   else
 276     vfm_source = create_case_source (&data_list_source_class, dls);
 277
 278   return CMD_SUCCESS;
 279
 280  error:
 281   data_list_trns_free (dls);
 282   return CMD_CASCADING_FAILURE;
 283 }
 284
 285 /* Adds SPEC to the linked list with head at FIRST and tail at
 286    LAST. */
 287 static void
 288 append_var_spec (struct dls_var_spec **first, struct dls_var_spec **last,
 289                  struct dls_var_spec *spec)
 290 {
 291   spec->next = NULL;
 292
 293   if (*first == NULL)
 294     *first = spec;
 295   else
 296     (*last)->next = spec;
 297   *last = spec;
 298 }
 299 \f
 300 /* Fixed-format parsing. */
 301
 302 /* Used for chaining together fortran-like format specifiers. */
 303 struct fmt_list
 304   {
 305     struct fmt_list *next;
 306     int count;
 307     struct fmt_spec f;
 308     struct fmt_list *down;
 309   };
 310
 311 /* State of parsing DATA LIST. */
 312 struct fixed_parsing_state
 313   {
 314     char **name;                /* Variable names. */
 315     size_t name_cnt;            /* Number of names. */
 316
 317     int recno;                  /* Index of current record. */
 318     int sc;                     /* 1-based column number of starting column for
 319                                    next field to output. */
 320   };
 321
 322 static int fixed_parse_compatible (struct fixed_parsing_state *,
 323                                    struct dls_var_spec **,
 324                                    struct dls_var_spec **);
 325 static int fixed_parse_fortran (struct fixed_parsing_state *,
 326                                 struct dls_var_spec **,
 327                                 struct dls_var_spec **);
 328
 329 /* Parses all the variable specifications for DATA LIST FIXED,
 330    storing them into DLS.  Returns nonzero if successful. */
 331 static int
 332 parse_fixed (struct data_list_pgm *dls)
 333 {
 334   struct fixed_parsing_state fx;
 335   size_t i;
 336
 337   fx.recno = 0;
 338   fx.sc = 1;
 339
 340   while (token != '.')
 341     {
 342       while (lex_match ('/'))
 343         {
 344           fx.recno++;
 345           if (lex_is_integer ())
 346             {
 347               if (lex_integer () < fx.recno)
 348                 {
 349                   msg (SE, _("The record number specified, %ld, is "
 350                              "before the previous record, %d.  Data "
 351                              "fields must be listed in order of "
 352                              "increasing record number."),
 353                        lex_integer (), fx.recno - 1);
 354                   return 0;
 355                 }
 356
 357               fx.recno = lex_integer ();
 358               lex_get ();
 359             }
 360           fx.sc = 1;
 361         }
 362
 363       if (!parse_DATA_LIST_vars (&fx.name, &fx.name_cnt, PV_NONE))
 364         return 0;
 365
 366       if (lex_is_number ())
 367         {
 368           if (!fixed_parse_compatible (&fx, &dls->first, &dls->last))
 369             goto fail;
 370         }
 371       else if (token == '(')
 372         {
 373           if (!fixed_parse_fortran (&fx, &dls->first, &dls->last))
 374             goto fail;
 375         }
 376       else
 377         {
 378           msg (SE, _("SPSS-like or FORTRAN-like format "
 379                      "specification expected after variable names."));
 380           goto fail;
 381         }
 382
 383       for (i = 0; i < fx.name_cnt; i++)
 384         free (fx.name[i]);
 385       free (fx.name);
 386     }
 387   if (dls->first == NULL)
 388     {
 389       msg (SE, _("At least one variable must be specified."));
 390       return 0;
 391     }
 392   if (dls->rec_cnt && dls->last->rec > dls->rec_cnt)
 393     {
 394       msg (SE, _("Variables are specified on records that "
 395                  "should not exist according to RECORDS subcommand."));
 396       return 0;
 397     }
 398   else if (!dls->rec_cnt)
 399     dls->rec_cnt = dls->last->rec;
 400   return lex_end_of_command () == CMD_SUCCESS;
 401
 402 fail:
 403   for (i = 0; i < fx.name_cnt; i++)
 404     free (fx.name[i]);
 405   free (fx.name);
 406   return 0;
 407 }
 408
 409 /* Parses a variable specification in the form 1-10 (A) based on
 410    FX and adds specifications to the linked list with head at
 411    FIRST and tail at LAST. */
 412 static int
 413 fixed_parse_compatible (struct fixed_parsing_state *fx,
 414                         struct dls_var_spec **first, struct dls_var_spec **last)
 415 {
 416   struct fmt_spec input;
 417   int fc, lc;
 418   int width;
 419   int i;
 420
 421   /* First column. */
 422   if (!lex_force_int ())
 423     return 0;
 424   fc = lex_integer ();
 425   if (fc < 1)
 426     {
 427       msg (SE, _("Column positions for fields must be positive."));
 428       return 0;
 429     }
 430   lex_get ();
 431
 432   /* Last column. */
 433   lex_negative_to_dash ();
 434   if (lex_match ('-'))
 435     {
 436       if (!lex_force_int ())
 437         return 0;
 438       lc = lex_integer ();
 439       if (lc < 1)
 440         {
 441           msg (SE, _("Column positions for fields must be positive."));
 442           return 0;
 443         }
 444       else if (lc < fc)
 445         {
 446           msg (SE, _("The ending column for a field must be "
 447                      "greater than the starting column."));
 448           return 0;
 449         }
 450
 451       lex_get ();
 452     }
 453   else
 454     lc = fc;
 455
 456   /* Divide columns evenly. */
 457   input.w = (lc - fc + 1) / fx->name_cnt;
 458   if ((lc - fc + 1) % fx->name_cnt)
 459     {
 460       msg (SE, _("The %d columns %d-%d "
 461                  "can't be evenly divided into %d fields."),
 462            lc - fc + 1, fc, lc, fx->name_cnt);
 463       return 0;
 464     }
 465
 466   /* Format specifier. */
 467   if (lex_match ('('))
 468     {
 469       struct fmt_desc *fdp;
 470
 471       if (token == T_ID)
 472         {
 473           const char *cp;
 474
 475           input.type = parse_format_specifier_name (&cp, 0);
 476           if (input.type == -1)
 477             return 0;
 478           if (*cp)
 479             {
 480               msg (SE, _("A format specifier on this line "
 481                          "has extra characters on the end."));
 482               return 0;
 483             }
 484
 485           lex_get ();
 486           lex_match (',');
 487         }
 488       else
 489         input.type = FMT_F;
 490
 491       if (lex_is_integer ())
 492         {
 493           if (lex_integer () < 1)
 494             {
 495               msg (SE, _("The value for number of decimal places "
 496                          "must be at least 1."));
 497               return 0;
 498             }
 499
 500           input.d = lex_integer ();
 501           lex_get ();
 502         }
 503       else
 504         input.d = 0;
 505
 506       fdp = &formats[input.type];
 507       if (fdp->n_args < 2 && input.d)
 508         {
 509           msg (SE, _("Input format %s doesn't accept decimal places."),
 510                fdp->name);
 511           return 0;
 512         }
 513
 514       if (input.d > 16)
 515         input.d = 16;
 516
 517       if (!lex_force_match (')'))
 518         return 0;
 519     }
 520   else
 521     {
 522       input.type = FMT_F;
 523       input.d = 0;
 524     }
 525   if (!check_input_specifier (&input, 1))
 526     return 0;
 527
 528   /* Start column for next specification. */
 529   fx->sc = lc + 1;
 530
 531   /* Width of variables to create. */
 532   if (input.type == FMT_A || input.type == FMT_AHEX)
 533     width = input.w;
 534   else
 535     width = 0;
 536
 537   /* Create variables and var specs. */
 538   for (i = 0; i < fx->name_cnt; i++)
 539     {
 540       struct dls_var_spec *spec;
 541       struct variable *v;
 542
 543       v = dict_create_var (default_dict, fx->name[i], width);
 544       if (v != NULL)
 545         {
 546           convert_fmt_ItoO (&input, &v->print);
 547           v->write = v->print;
 548           if (!case_source_is_complex (vfm_source))
 549             v->init = 0;
 550         }
 551       else
 552         {
 553           v = dict_lookup_var_assert (default_dict, fx->name[i]);
 554           if (vfm_source == NULL)
 555             {
 556               msg (SE, _("%s is a duplicate variable name."), fx->name[i]);
 557               return 0;
 558             }
 559           if ((width != 0) != (v->width != 0))
 560             {
 561               msg (SE, _("There is already a variable %s of a "
 562                          "different type."),
 563                    fx->name[i]);
 564               return 0;
 565             }
 566           if (width != 0 && width != v->width)
 567             {
 568               msg (SE, _("There is already a string variable %s of a "
 569                          "different width."), fx->name[i]);
 570               return 0;
 571             }
 572         }
 573
 574       spec = xmalloc (sizeof *spec);
 575       spec->input = input;
 576       spec->v = v;
 577       spec->fv = v->fv;
 578       spec->rec = fx->recno;
 579       spec->fc = fc + input.w * i;
 580       spec->lc = spec->fc + input.w - 1;
 581       append_var_spec (first, last, spec);
 582     }
 583   return 1;
 584 }
 585
 586 /* Destroy format list F and, if RECURSE is nonzero, all its
 587    sublists. */
 588 static void
 589 destroy_fmt_list (struct fmt_list *f, int recurse)
 590 {
 591   struct fmt_list *next;
 592
 593   for (; f; f = next)
 594     {
 595       next = f->next;
 596       if (recurse && f->f.type == FMT_DESCEND)
 597         destroy_fmt_list (f->down, 1);
 598       free (f);
 599     }
 600 }
 601
 602 /* Takes a hierarchically structured fmt_list F as constructed by
 603    fixed_parse_fortran(), and flattens it, adding the variable
 604    specifications to the linked list with head FIRST and tail
 605    LAST.  NAME_IDX is used to take values from the list of names
 606    in FX; it should initially point to a value of 0. */
 607 static int
 608 dump_fmt_list (struct fixed_parsing_state *fx, struct fmt_list *f,
 609                struct dls_var_spec **first, struct dls_var_spec **last,
 610                int *name_idx)
 611 {
 612   int i;
 613
 614   for (; f; f = f->next)
 615     if (f->f.type == FMT_X)
 616       fx->sc += f->count;
 617     else if (f->f.type == FMT_T)
 618       fx->sc = f->f.w;
 619     else if (f->f.type == FMT_NEWREC)
 620       {
 621         fx->recno += f->count;
 622         fx->sc = 1;
 623       }
 624     else
 625       for (i = 0; i < f->count; i++)
 626         if (f->f.type == FMT_DESCEND)
 627           {
 628             if (!dump_fmt_list (fx, f->down, first, last, name_idx))
 629               return 0;
 630           }
 631         else
 632           {
 633             struct dls_var_spec *spec;
 634             int width;
 635             struct variable *v;
 636
 637             if (formats[f->f.type].cat & FCAT_STRING)
 638               width = f->f.w;
 639             else
 640               width = 0;
 641             if (*name_idx >= fx->name_cnt)
 642               {
 643                 msg (SE, _("The number of format "
 644                            "specifications exceeds the given number of "
 645                            "variable names."));
 646                 return 0;
 647               }
 648
 649             v = dict_create_var (default_dict, fx->name[(*name_idx)++], width);
 650             if (!v)
 651               {
 652                 msg (SE, _("%s is a duplicate variable name."), fx->name[i]);
 653                 return 0;
 654               }
 655
 656             if (!case_source_is_complex (vfm_source))
 657               v->init = 0;
 658
 659             spec = xmalloc (sizeof *spec);
 660             spec->v = v;
 661             spec->input = f->f;
 662             spec->fv = v->fv;
 663             spec->rec = fx->recno;
 664             spec->fc = fx->sc;
 665             spec->lc = fx->sc + f->f.w - 1;
 666             append_var_spec (first, last, spec);
 667
 668             convert_fmt_ItoO (&spec->input, &v->print);
 669             v->write = v->print;
 670
 671             fx->sc += f->f.w;
 672           }
 673   return 1;
 674 }
 675
 676 /* Recursively parses a FORTRAN-like format specification into
 677    the linked list with head FIRST and tail TAIL.  LEVEL is the
 678    level of recursion, starting from 0.  Returns the parsed
 679    specification if successful, or a null pointer on failure.  */
 680 static struct fmt_list *
 681 fixed_parse_fortran_internal (struct fixed_parsing_state *fx,
 682                               struct dls_var_spec **first,
 683                               struct dls_var_spec **last)
 684 {
 685   struct fmt_list *head = NULL;
 686   struct fmt_list *tail = NULL;
 687
 688   lex_force_match ('(');
 689   while (token != ')')
 690     {
 691       /* New fmt_list. */
 692       struct fmt_list *new = xmalloc (sizeof *new);
 693       new->next = NULL;
 694
 695       /* Append new to list. */
 696       if (head != NULL)
 697         tail->next = new;
 698       else
 699         head = new;
 700       tail = new;
 701
 702       /* Parse count. */
 703       if (lex_is_integer ())
 704         {
 705           new->count = lex_integer ();
 706           lex_get ();
 707         }
 708       else
 709         new->count = 1;
 710
 711       /* Parse format specifier. */
 712       if (token == '(')
 713         {
 714           new->f.type = FMT_DESCEND;
 715           new->down = fixed_parse_fortran_internal (fx, first, last);
 716           if (new->down == NULL)
 717             goto fail;
 718         }
 719       else if (lex_match ('/'))
 720         new->f.type = FMT_NEWREC;
 721       else if (!parse_format_specifier (&new->f, FMTP_ALLOW_XT)
 722                || !check_input_specifier (&new->f, 1))
 723         goto fail;
 724
 725       lex_match (',');
 726     }
 727   lex_force_match (')');
 728
 729   return head;
 730
 731 fail:
 732   destroy_fmt_list (head, 0);
 733
 734   return NULL;
 735 }
 736
 737 /* Parses a FORTRAN-like format specification into the linked
 738    list with head FIRST and tail LAST.  Returns nonzero if
 739    successful. */
 740 static int
 741 fixed_parse_fortran (struct fixed_parsing_state *fx,
 742                      struct dls_var_spec **first, struct dls_var_spec **last)
 743 {
 744   struct fmt_list *list;
 745   int name_idx;
 746
 747   list = fixed_parse_fortran_internal (fx, first, last);
 748   if (list == NULL)
 749     return 0;
 750
 751   name_idx = 0;
 752   dump_fmt_list (fx, list, first, last, &name_idx);
 753   destroy_fmt_list (list, 1);
 754   if (name_idx < fx->name_cnt)
 755     {
 756       msg (SE, _("There aren't enough format specifications "
 757                  "to match the number of variable names given."));
 758       return 0;
 759     }
 760
 761   return 1;
 762 }
 763
 764 /* Displays a table giving information on fixed-format variable
 765    parsing on DATA LIST. */
 766 /* FIXME: The `Columns' column should be divided into three columns,
 767    one for the starting column, one for the dash, one for the ending
 768    column; then right-justify the starting column and left-justify the
 769    ending column. */
 770 static void
 771 dump_fixed_table (const struct dls_var_spec *specs,
 772                   const struct file_handle *fh, int rec_cnt)
 773 {
 774   const struct dls_var_spec *spec;
 775   struct tab_table *t;
 776   int i;
 777
 778   for (i = 0, spec = specs; spec; spec = spec->next)
 779     i++;
 780   t = tab_create (4, i + 1, 0);
 781   tab_columns (t, TAB_COL_DOWN, 1);
 782   tab_headers (t, 0, 0, 1, 0);
 783   tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable"));
 784   tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Record"));
 785   tab_text (t, 2, 0, TAB_CENTER | TAT_TITLE, _("Columns"));
 786   tab_text (t, 3, 0, TAB_CENTER | TAT_TITLE, _("Format"));
 787   tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 3, i);
 788   tab_hline (t, TAL_2, 0, 3, 1);
 789   tab_dim (t, tab_natural_dimensions);
 790
 791   for (i = 1, spec = specs; spec; spec = spec->next, i++)
 792     {
 793       tab_text (t, 0, i, TAB_LEFT, spec->v->name);
 794       tab_text (t, 1, i, TAT_PRINTF, "%d", spec->rec);
 795       tab_text (t, 2, i, TAT_PRINTF, "%3d-%3d",
 796                     spec->fc, spec->lc);
 797       tab_text (t, 3, i, TAB_LEFT | TAB_FIX,
 798                     fmt_to_string (&spec->input));
 799     }
 800
 801   tab_title (t, ngettext ("Reading %d record from %s.",
 802                           "Reading %d records from %s.", rec_cnt),
 803              rec_cnt, fh_get_name (fh));
 804   tab_submit (t);
 805 }
 806 \f
 807 /* Free-format parsing. */
 808
 809 /* Parses variable specifications for DATA LIST FREE and adds
 810    them to the linked list with head FIRST and tail LAST.
 811    Returns nonzero only if successful. */
 812 static int
 813 parse_free (struct dls_var_spec **first, struct dls_var_spec **last)
 814 {
 815   lex_get ();
 816   while (token != '.')
 817     {
 818       struct fmt_spec input, output;
 819       char **name;
 820       size_t name_cnt;
 821       int width;
 822       size_t i;
 823
 824       if (!parse_DATA_LIST_vars (&name, &name_cnt, PV_NONE))
 825         return 0;
 826
 827       if (lex_match ('('))
 828         {
 829           if (!parse_format_specifier (&input, 0)
 830               || !check_input_specifier (&input, 1)
 831               || !lex_force_match (')'))
 832             {
 833               for (i = 0; i < name_cnt; i++)
 834                 free (name[i]);
 835               free (name);
 836               return 0;
 837             }
 838           convert_fmt_ItoO (&input, &output);
 839         }
 840       else
 841         {
 842           lex_match ('*');
 843           input = make_input_format (FMT_F, 8, 0);
 844           output = *get_format ();
 845         }
 846
 847       if (input.type == FMT_A || input.type == FMT_AHEX)
 848         width = input.w;
 849       else
 850         width = 0;
 851       for (i = 0; i < name_cnt; i++)
 852         {
 853           struct dls_var_spec *spec;
 854           struct variable *v;
 855
 856           v = dict_create_var (default_dict, name[i], width);
 857
 858           if (!v)
 859             {
 860               msg (SE, _("%s is a duplicate variable name."), name[i]);
 861               return 0;
 862             }
 863           v->print = v->write = output;
 864
 865           if (!case_source_is_complex (vfm_source))
 866             v->init = 0;
 867
 868           spec = xmalloc (sizeof *spec);
 869           spec->input = input;
 870           spec->v = v;
 871           spec->fv = v->fv;
 872           str_copy_trunc (spec->name, sizeof spec->name, v->name);
 873           append_var_spec (first, last, spec);
 874         }
 875       for (i = 0; i < name_cnt; i++)
 876         free (name[i]);
 877       free (name);
 878     }
 879
 880   return lex_end_of_command () == CMD_SUCCESS;
 881 }
 882
 883 /* Displays a table giving information on free-format variable parsing
 884    on DATA LIST. */
 885 static void
 886 dump_free_table (const struct data_list_pgm *dls,
 887                  const struct file_handle *fh)
 888 {
 889   struct tab_table *t;
 890   int i;
 891
 892   {
 893     struct dls_var_spec *spec;
 894     for (i = 0, spec = dls->first; spec; spec = spec->next)
 895       i++;
 896   }
 897
 898   t = tab_create (2, i + 1, 0);
 899   tab_columns (t, TAB_COL_DOWN, 1);
 900   tab_headers (t, 0, 0, 1, 0);
 901   tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable"));
 902   tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Format"));
 903   tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 1, i);
 904   tab_hline (t, TAL_2, 0, 1, 1);
 905   tab_dim (t, tab_natural_dimensions);
 906
 907   {
 908     struct dls_var_spec *spec;
 909
 910     for (i = 1, spec = dls->first; spec; spec = spec->next, i++)
 911       {
 912         tab_text (t, 0, i, TAB_LEFT, spec->v->name);
 913         tab_text (t, 1, i, TAB_LEFT | TAB_FIX, fmt_to_string (&spec->input));
 914       }
 915   }
 916
 917   tab_title (t, _("Reading free-form data from %s."), fh_get_name (fh));
 918
 919   tab_submit (t);
 920 }
 921 \f
 922 /* Input procedure. */
 923
 924 /* Extracts a field from the current position in the current
 925    record.  Fields can be unquoted or quoted with single- or
 926    double-quote characters.  *FIELD is set to the field content.
 927    After parsing the field, sets the current position in the
 928    record to just past the field and any trailing delimiter.
 929    END_BLANK is used internally; it should be initialized by the
 930    caller to 0 and left alone afterward.  Returns 0 on failure or
 931    a 1-based column number indicating the beginning of the field
 932    on success. */
 933 static int
 934 cut_field (const struct data_list_pgm *dls, struct fixed_string *field,
 935            int *end_blank)
 936 {
 937   struct fixed_string line;
 938   char *cp;
 939   size_t column_start;
 940
 941   if (dfm_eof (dls->reader))
 942     return 0;
 943   if (dls->delim_cnt == 0)
 944     dfm_expand_tabs (dls->reader);
 945   dfm_get_record (dls->reader, &line);
 946
 947   cp = ls_c_str (&line);
 948   if (dls->delim_cnt == 0)
 949     {
 950       /* Skip leading whitespace. */
 951       while (cp < ls_end (&line) && isspace ((unsigned char) *cp))
 952         cp++;
 953       if (cp >= ls_end (&line))
 954         return 0;
 955
 956       /* Handle actual data, whether quoted or unquoted. */
 957       if (*cp == '\'' || *cp == '"')
 958         {
 959           int quote = *cp;
 960
 961           field->string = ++cp;
 962           while (cp < ls_end (&line) && *cp != quote)
 963             cp++;
 964           field->length = cp - field->string;
 965           if (cp < ls_end (&line))
 966             cp++;
 967           else
 968             msg (SW, _("Quoted string missing terminating `%c'."), quote);
 969         }
 970       else
 971         {
 972           field->string = cp;
 973           while (cp < ls_end (&line)
 974                  && !isspace ((unsigned char) *cp) && *cp != ',')
 975             cp++;
 976           field->length = cp - field->string;
 977         }
 978
 979       /* Skip trailing whitespace and a single comma if present. */
 980       while (cp < ls_end (&line) && isspace ((unsigned char) *cp))
 981         cp++;
 982       if (cp < ls_end (&line) && *cp == ',')
 983         cp++;
 984     }
 985   else
 986     {
 987       if (cp >= ls_end (&line))
 988         {
 989           int column = dfm_column_start (dls->reader);
 990                /* A blank line or a line that ends in \t has a
 991              trailing blank field. */
 992           if (column == 1 || (column > 1 && cp[-1] == '\t'))
 993             {
 994               if (*end_blank == 0)
 995                 {
 996                   *end_blank = 1;
 997                   field->string = ls_end (&line);
 998                   field->length = 0;
 999                   dfm_forward_record (dls->reader);
1000                   return column;
1001                 }
1002               else
1003                 {
1004                   *end_blank = 0;
1005                   return 0;
1006                 }
1007             }
1008           else
1009             return 0;
1010         }
1011       else
1012         {
1013           field->string = cp;
1014           while (cp < ls_end (&line)
1015                  && memchr (dls->delims, *cp, dls->delim_cnt) == NULL)
1016             cp++;
1017           field->length = cp - field->string;
1018           if (cp < ls_end (&line))
1019             cp++;
1020         }
1021     }
1022
1023   dfm_forward_columns (dls->reader, field->string - line.string);
1024   column_start = dfm_column_start (dls->reader);
1025
1026   dfm_forward_columns (dls->reader, cp - field->string);
1027
1028   return column_start;
1029 }
1030
1031 static bool read_from_data_list_fixed (const struct data_list_pgm *,
1032                                        struct ccase *);
1033 static bool read_from_data_list_free (const struct data_list_pgm *,
1034                                       struct ccase *);
1035 static bool read_from_data_list_list (const struct data_list_pgm *,
1036                                       struct ccase *);
1037
1038 /* Reads a case from DLS into C.
1039    Returns true if successful, false at end of file or on I/O error. */
1040 static bool
1041 read_from_data_list (const struct data_list_pgm *dls, struct ccase *c)
1042 {
1043   bool retval;
1044
1045   dfm_push (dls->reader);
1046   switch (dls->type)
1047     {
1048     case DLS_FIXED:
1049       retval = read_from_data_list_fixed (dls, c);
1050       break;
1051     case DLS_FREE:
1052       retval = read_from_data_list_free (dls, c);
1053       break;
1054     case DLS_LIST:
1055       retval = read_from_data_list_list (dls, c);
1056       break;
1057     default:
1058       abort ();
1059     }
1060   dfm_pop (dls->reader);
1061
1062   return retval;
1063 }
1064
1065 /* Reads a case from the data file into C, parsing it according
1066    to fixed-format syntax rules in DLS.
1067    Returns true if successful, false at end of file or on I/O error. */
1068 static bool
1069 read_from_data_list_fixed (const struct data_list_pgm *dls, struct ccase *c)
1070 {
1071   struct dls_var_spec *var_spec = dls->first;
1072   int i;
1073
1074   if (dfm_eof (dls->reader))
1075     return false;
1076   for (i = 1; i <= dls->rec_cnt; i++)
1077     {
1078       struct fixed_string line;
1079
1080       if (dfm_eof (dls->reader))
1081         {
1082           /* Note that this can't occur on the first record. */
1083           msg (SW, _("Partial case of %d of %d records discarded."),
1084                i - 1, dls->rec_cnt);
1085           return false;
1086         }
1087       dfm_expand_tabs (dls->reader);
1088       dfm_get_record (dls->reader, &line);
1089
1090       for (; var_spec && i == var_spec->rec; var_spec = var_spec->next)
1091         {
1092           struct data_in di;
1093
1094           data_in_finite_line (&di, ls_c_str (&line), ls_length (&line),
1095                                var_spec->fc, var_spec->lc);
1096           di.v = case_data_rw (c, var_spec->fv);
1097           di.flags = DI_IMPLIED_DECIMALS;
1098           di.f1 = var_spec->fc;
1099           di.format = var_spec->input;
1100
1101           data_in (&di);
1102         }
1103
1104       dfm_forward_record (dls->reader);
1105     }
1106
1107   return true;
1108 }
1109
1110 /* Reads a case from the data file into C, parsing it according
1111    to free-format syntax rules in DLS.
1112    Returns true if successful, false at end of file or on I/O error. */
1113 static bool
1114 read_from_data_list_free (const struct data_list_pgm *dls, struct ccase *c)
1115 {
1116   struct dls_var_spec *var_spec;
1117   int end_blank = 0;
1118
1119   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1120     {
1121       struct fixed_string field;
1122       int column;
1123
1124       /* Cut out a field and read in a new record if necessary. */
1125       for (;;)
1126         {
1127           column = cut_field (dls, &field, &end_blank);
1128           if (column != 0)
1129             break;
1130
1131           if (!dfm_eof (dls->reader))
1132             dfm_forward_record (dls->reader);
1133           if (dfm_eof (dls->reader))
1134             {
1135               if (var_spec != dls->first)
1136                 msg (SW, _("Partial case discarded.  The first variable "
1137                            "missing was %s."), var_spec->name);
1138               return false;
1139             }
1140         }
1141
1142       {
1143         struct data_in di;
1144
1145         di.s = ls_c_str (&field);
1146         di.e = ls_end (&field);
1147         di.v = case_data_rw (c, var_spec->fv);
1148         di.flags = 0;
1149         di.f1 = column;
1150         di.format = var_spec->input;
1151         data_in (&di);
1152       }
1153     }
1154   return true;
1155 }
1156
1157 /* Reads a case from the data file and parses it according to
1158    list-format syntax rules.
1159    Returns true if successful, false at end of file or on I/O error. */
1160 static bool
1161 read_from_data_list_list (const struct data_list_pgm *dls, struct ccase *c)
1162 {
1163   struct dls_var_spec *var_spec;
1164   int end_blank = 0;
1165
1166   if (dfm_eof (dls->reader))
1167     return false;
1168
1169   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1170     {
1171       struct fixed_string field;
1172       int column;
1173
1174       /* Cut out a field and check for end-of-line. */
1175       column = cut_field (dls, &field, &end_blank);
1176       if (column == 0)
1177         {
1178           if (get_undefined ())
1179             msg (SW, _("Missing value(s) for all variables from %s onward.  "
1180                        "These will be filled with the system-missing value "
1181                        "or blanks, as appropriate."),
1182                  var_spec->name);
1183           for (; var_spec; var_spec = var_spec->next)
1184             {
1185               int width = get_format_var_width (&var_spec->input);
1186               if (width == 0)
1187                 case_data_rw (c, var_spec->fv)->f = SYSMIS;
1188               else
1189                 memset (case_data_rw (c, var_spec->fv)->s, ' ', width);
1190             }
1191           break;
1192         }
1193
1194       {
1195         struct data_in di;
1196
1197         di.s = ls_c_str (&field);
1198         di.e = ls_end (&field);
1199         di.v = case_data_rw (c, var_spec->fv);
1200         di.flags = 0;
1201         di.f1 = column;
1202         di.format = var_spec->input;
1203         data_in (&di);
1204       }
1205     }
1206
1207   dfm_forward_record (dls->reader);
1208   return true;
1209 }
1210
1211 /* Destroys SPEC. */
1212 static void
1213 destroy_dls_var_spec (struct dls_var_spec *spec)
1214 {
1215   struct dls_var_spec *next;
1216
1217   while (spec != NULL)
1218     {
1219       next = spec->next;
1220       free (spec);
1221       spec = next;
1222     }
1223 }
1224
1225 /* Destroys DATA LIST transformation DLS.
1226    Returns true if successful, false if an I/O error occurred. */
1227 static bool
1228 data_list_trns_free (void *dls_)
1229 {
1230   struct data_list_pgm *dls = dls_;
1231   free (dls->delims);
1232   destroy_dls_var_spec (dls->first);
1233   dfm_close_reader (dls->reader);
1234   free (dls);
1235   return true;
1236 }
1237
1238 /* Handle DATA LIST transformation DLS, parsing data into C. */
1239 static int
1240 data_list_trns_proc (void *dls_, struct ccase *c, int case_num UNUSED)
1241 {
1242   struct data_list_pgm *dls = dls_;
1243   int retval;
1244
1245   if (read_from_data_list (dls, c))
1246     retval = TRNS_CONTINUE;
1247   else if (dfm_reader_error (dls->reader) || dfm_eof (dls->reader) > 1)
1248     {
1249       /* An I/O error, or encountering end of file for a second
1250          time, should be escalated into a more serious error. */
1251       retval = TRNS_ERROR;
1252     }
1253   else
1254     retval = TRNS_DROP_CASE;
1255
1256   /* If there was an END subcommand handle it. */
1257   if (dls->end != NULL)
1258     {
1259       double *end = &case_data_rw (c, dls->end->fv)->f;
1260       if (retval == TRNS_DROP_CASE)
1261         {
1262           *end = 1.0;
1263           retval = TRNS_CONTINUE;
1264         }
1265       else
1266         *end = 0.0;
1267     }
1268
1269   return retval;
1270 }
1271 \f
1272 /* Reads all the records from the data file and passes them to
1273    write_case().
1274    Returns true if successful, false if an I/O error occurred. */
1275 static bool
1276 data_list_source_read (struct case_source *source,
1277                        struct ccase *c,
1278                        write_case_func *write_case, write_case_data wc_data)
1279 {
1280   struct data_list_pgm *dls = source->aux;
1281
1282   for (;;)
1283     {
1284       bool ok;
1285
1286       if (!read_from_data_list (dls, c))
1287         return !dfm_reader_error (dls->reader);
1288
1289       dfm_push (dls->reader);
1290       ok = write_case (wc_data);
1291       dfm_pop (dls->reader);
1292       if (!ok)
1293         return false;
1294     }
1295 }
1296
1297 /* Destroys the source's internal data. */
1298 static void
1299 data_list_source_destroy (struct case_source *source)
1300 {
1301   data_list_trns_free (source->aux);
1302 }
1303
1304 static const struct case_source_class data_list_source_class =
1305   {
1306     "DATA LIST",
1307     NULL,
1308     data_list_source_read,
1309     data_list_source_destroy,
1310   };
1311 \f
1312 /* REPEATING DATA. */
1313
1314 /* Represents a number or a variable. */
1315 struct rpd_num_or_var
1316   {
1317     int num;                    /* Value, or 0. */
1318     struct variable *var;       /* Variable, if number==0. */
1319   };
1320
1321 /* REPEATING DATA private data structure. */
1322 struct repeating_data_trns
1323   {
1324     struct dls_var_spec *first, *last;  /* Variable parsing specifications. */
1325     struct dfm_reader *reader;          /* Input file, never NULL. */
1326
1327     struct rpd_num_or_var starts_beg;   /* STARTS=, before the dash. */
1328     struct rpd_num_or_var starts_end;   /* STARTS=, after the dash. */
1329     struct rpd_num_or_var occurs;       /* OCCURS= subcommand. */
1330     struct rpd_num_or_var length;       /* LENGTH= subcommand. */
1331     struct rpd_num_or_var cont_beg;     /* CONTINUED=, before the dash. */
1332     struct rpd_num_or_var cont_end;     /* CONTINUED=, after the dash. */
1333
1334     /* ID subcommand. */
1335     int id_beg, id_end;                 /* Beginning & end columns. */
1336     struct variable *id_var;            /* DATA LIST variable. */
1337     struct fmt_spec id_spec;            /* Input format spec. */
1338     union value *id_value;              /* ID value. */
1339
1340     write_case_func *write_case;
1341     write_case_data wc_data;
1342   };
1343
1344 static trns_free_func repeating_data_trns_free;
1345 static int parse_num_or_var (struct rpd_num_or_var *, const char *);
1346 static int parse_repeating_data (struct dls_var_spec **,
1347                                  struct dls_var_spec **);
1348 static void find_variable_input_spec (struct variable *v,
1349                                       struct fmt_spec *spec);
1350
1351 int cmd_repeating_data (void);
1352
1353 /* Parses the REPEATING DATA command. */
1354 int
1355 cmd_repeating_data (void)
1356 {
1357   struct repeating_data_trns *rpd;
1358   int table = 1;                /* Print table? */
1359   bool saw_starts = false;      /* Saw STARTS subcommand? */
1360   bool saw_occurs = false;      /* Saw OCCURS subcommand? */
1361   bool saw_length = false;      /* Saw LENGTH subcommand? */
1362   bool saw_continued = false;   /* Saw CONTINUED subcommand? */
1363   bool saw_id = false;          /* Saw ID subcommand? */
1364   struct file_handle *const fh = fh_get_default_handle ();
1365
1366   assert (case_source_is_complex (vfm_source));
1367
1368   rpd = xmalloc (sizeof *rpd);
1369   rpd->reader = dfm_open_reader (fh);
1370   rpd->first = rpd->last = NULL;
1371   rpd->starts_beg.num = 0;
1372   rpd->starts_beg.var = NULL;
1373   rpd->starts_end = rpd->occurs = rpd->length = rpd->cont_beg
1374     = rpd->cont_end = rpd->starts_beg;
1375   rpd->id_beg = rpd->id_end = 0;
1376   rpd->id_var = NULL;
1377   rpd->id_value = NULL;
1378
1379   lex_match ('/');
1380
1381   for (;;)
1382     {
1383       if (lex_match_id ("FILE"))
1384         {
1385           struct file_handle *file;
1386           lex_match ('=');
1387           file = fh_parse (FH_REF_FILE | FH_REF_INLINE);
1388           if (file == NULL)
1389             goto error;
1390           if (file != fh)
1391             {
1392               msg (SE, _("REPEATING DATA must use the same file as its "
1393                          "corresponding DATA LIST or FILE TYPE."));
1394               goto error;
1395             }
1396         }
1397       else if (lex_match_id ("STARTS"))
1398         {
1399           lex_match ('=');
1400           if (saw_starts)
1401             {
1402               msg (SE, _("%s subcommand given multiple times."),"STARTS");
1403               goto error;
1404             }
1405           saw_starts = true;
1406
1407           if (!parse_num_or_var (&rpd->starts_beg, "STARTS beginning column"))
1408             goto error;
1409
1410           lex_negative_to_dash ();
1411           if (lex_match ('-'))
1412             {
1413               if (!parse_num_or_var (&rpd->starts_end, "STARTS ending column"))
1414                 goto error;
1415             } else {
1416               /* Otherwise, rpd->starts_end is uninitialized.  We
1417                  will initialize it later from the record length
1418                  of the file.  We can't do so now because the
1419                  file handle may not be specified yet. */
1420             }
1421
1422           if (rpd->starts_beg.num != 0 && rpd->starts_end.num != 0
1423               && rpd->starts_beg.num > rpd->starts_end.num)
1424             {
1425               msg (SE, _("STARTS beginning column (%d) exceeds "
1426                          "STARTS ending column (%d)."),
1427                    rpd->starts_beg.num, rpd->starts_end.num);
1428               goto error;
1429             }
1430         }
1431       else if (lex_match_id ("OCCURS"))
1432         {
1433           lex_match ('=');
1434           if (saw_occurs)
1435             {
1436               msg (SE, _("%s subcommand given multiple times."),"OCCURS");
1437               goto error;
1438             }
1439           saw_occurs = true;
1440
1441           if (!parse_num_or_var (&rpd->occurs, "OCCURS"))
1442             goto error;
1443         }
1444       else if (lex_match_id ("LENGTH"))
1445         {
1446           lex_match ('=');
1447           if (saw_length)
1448             {
1449               msg (SE, _("%s subcommand given multiple times."),"LENGTH");
1450               goto error;
1451             }
1452           saw_length = true;
1453
1454           if (!parse_num_or_var (&rpd->length, "LENGTH"))
1455             goto error;
1456         }
1457       else if (lex_match_id ("CONTINUED"))
1458         {
1459           lex_match ('=');
1460           if (saw_continued)
1461             {
1462               msg (SE, _("%s subcommand given multiple times."),"CONTINUED");
1463               goto error;
1464             }
1465           saw_continued = true;
1466
1467           if (!lex_match ('/'))
1468             {
1469               if (!parse_num_or_var (&rpd->cont_beg,
1470                                      "CONTINUED beginning column"))
1471                 goto error;
1472
1473               lex_negative_to_dash ();
1474               if (lex_match ('-')
1475                   && !parse_num_or_var (&rpd->cont_end,
1476                                         "CONTINUED ending column"))
1477                 goto error;
1478
1479               if (rpd->cont_beg.num != 0 && rpd->cont_end.num != 0
1480                   && rpd->cont_beg.num > rpd->cont_end.num)
1481                 {
1482                   msg (SE, _("CONTINUED beginning column (%d) exceeds "
1483                              "CONTINUED ending column (%d)."),
1484                        rpd->cont_beg.num, rpd->cont_end.num);
1485                   goto error;
1486                 }
1487             }
1488           else
1489             rpd->cont_beg.num = 1;
1490         }
1491       else if (lex_match_id ("ID"))
1492         {
1493           lex_match ('=');
1494           if (saw_id)
1495             {
1496               msg (SE, _("%s subcommand given multiple times."),"ID");
1497               goto error;
1498             }
1499           saw_id = true;
1500
1501           if (!lex_force_int ())
1502             goto error;
1503           if (lex_integer () < 1)
1504             {
1505               msg (SE, _("ID beginning column (%ld) must be positive."),
1506                    lex_integer ());
1507               goto error;
1508             }
1509           rpd->id_beg = lex_integer ();
1510
1511           lex_get ();
1512           lex_negative_to_dash ();
1513
1514           if (lex_match ('-'))
1515             {
1516               if (!lex_force_int ())
1517                 goto error;
1518               if (lex_integer () < 1)
1519                 {
1520                   msg (SE, _("ID ending column (%ld) must be positive."),
1521                        lex_integer ());
1522                   goto error;
1523                 }
1524               if (lex_integer () < rpd->id_end)
1525                 {
1526                   msg (SE, _("ID ending column (%ld) cannot be less than "
1527                              "ID beginning column (%d)."),
1528                        lex_integer (), rpd->id_beg);
1529                   goto error;
1530                 }
1531
1532               rpd->id_end = lex_integer ();
1533               lex_get ();
1534             }
1535           else rpd->id_end = rpd->id_beg;
1536
1537           if (!lex_force_match ('='))
1538             goto error;
1539           rpd->id_var = parse_variable ();
1540           if (rpd->id_var == NULL)
1541             goto error;
1542
1543           find_variable_input_spec (rpd->id_var, &rpd->id_spec);
1544           rpd->id_value = xnmalloc (rpd->id_var->nv, sizeof *rpd->id_value);
1545         }
1546       else if (lex_match_id ("TABLE"))
1547         table = 1;
1548       else if (lex_match_id ("NOTABLE"))
1549         table = 0;
1550       else if (lex_match_id ("DATA"))
1551         break;
1552       else
1553         {
1554           lex_error (NULL);
1555           goto error;
1556         }
1557
1558       if (!lex_force_match ('/'))
1559         goto error;
1560     }
1561
1562   /* Comes here when DATA specification encountered. */
1563   if (!saw_starts || !saw_occurs)
1564     {
1565       if (!saw_starts)
1566         msg (SE, _("Missing required specification STARTS."));
1567       if (!saw_occurs)
1568         msg (SE, _("Missing required specification OCCURS."));
1569       goto error;
1570     }
1571
1572   /* Enforce ID restriction. */
1573   if (saw_id && !saw_continued)
1574     {
1575       msg (SE, _("ID specified without CONTINUED."));
1576       goto error;
1577     }
1578
1579   /* Calculate and check starts_end, cont_end if necessary. */
1580   if (rpd->starts_end.num == 0 && rpd->starts_end.var == NULL)
1581     {
1582       rpd->starts_end.num = fh_get_record_width (fh);
1583       if (rpd->starts_beg.num != 0
1584           && rpd->starts_beg.num > rpd->starts_end.num)
1585         {
1586           msg (SE, _("STARTS beginning column (%d) exceeds "
1587                      "default STARTS ending column taken from file's "
1588                      "record width (%d)."),
1589                rpd->starts_beg.num, rpd->starts_end.num);
1590           goto error;
1591         }
1592     }
1593   if (rpd->cont_end.num == 0 && rpd->cont_end.var == NULL)
1594     {
1595       rpd->cont_end.num = fh_get_record_width (fh);
1596       if (rpd->cont_beg.num != 0
1597           && rpd->cont_beg.num > rpd->cont_end.num)
1598         {
1599           msg (SE, _("CONTINUED beginning column (%d) exceeds "
1600                      "default CONTINUED ending column taken from file's "
1601                      "record width (%d)."),
1602                rpd->cont_beg.num, rpd->cont_end.num);
1603           goto error;
1604         }
1605     }
1606
1607   lex_match ('=');
1608   if (!parse_repeating_data (&rpd->first, &rpd->last))
1609     goto error;
1610
1611   /* Calculate length if necessary. */
1612   if (!saw_length)
1613     {
1614       struct dls_var_spec *iter;
1615
1616       for (iter = rpd->first; iter; iter = iter->next)
1617         if (iter->lc > rpd->length.num)
1618           rpd->length.num = iter->lc;
1619       assert (rpd->length.num != 0);
1620     }
1621
1622   if (table)
1623     dump_fixed_table (rpd->first, fh, rpd->last->rec);
1624
1625   add_transformation (repeating_data_trns_proc, repeating_data_trns_free, rpd);
1626
1627   return lex_end_of_command ();
1628
1629  error:
1630   repeating_data_trns_free (rpd);
1631   return CMD_CASCADING_FAILURE;
1632 }
1633
1634 /* Finds the input format specification for variable V and puts
1635    it in SPEC.  Because of the way that DATA LIST is structured,
1636    this is nontrivial. */
1637 static void
1638 find_variable_input_spec (struct variable *v, struct fmt_spec *spec)
1639 {
1640   size_t i;
1641
1642   for (i = 0; i < n_trns; i++)
1643     {
1644       struct transformation *trns = &t_trns[i];
1645
1646       if (trns->proc == data_list_trns_proc)
1647         {
1648           struct data_list_pgm *pgm = trns->private;
1649           struct dls_var_spec *iter;
1650
1651           for (iter = pgm->first; iter; iter = iter->next)
1652             if (iter->v == v)
1653               {
1654                 *spec = iter->input;
1655                 return;
1656               }
1657         }
1658     }
1659
1660   assert (0);
1661 }
1662
1663 /* Parses a number or a variable name from the syntax file and puts
1664    the results in VALUE.  Ensures that the number is at least 1; else
1665    emits an error based on MESSAGE.  Returns nonzero only if
1666    successful. */
1667 static int
1668 parse_num_or_var (struct rpd_num_or_var *value, const char *message)
1669 {
1670   if (token == T_ID)
1671     {
1672       value->num = 0;
1673       value->var = parse_variable ();
1674       if (value->var == NULL)
1675         return 0;
1676       if (value->var->type == ALPHA)
1677         {
1678           msg (SE, _("String variable not allowed here."));
1679           return 0;
1680         }
1681     }
1682   else if (lex_is_integer ())
1683     {
1684       value->num = lex_integer ();
1685
1686       if (value->num < 1)
1687         {
1688           msg (SE, _("%s (%d) must be at least 1."), message, value->num);
1689           return 0;
1690         }
1691
1692       lex_get ();
1693     } else {
1694       msg (SE, _("Variable or integer expected for %s."), message);
1695       return 0;
1696     }
1697   return 1;
1698 }
1699
1700 /* Parses data specifications for repeating data groups, adding
1701    them to the linked list with head FIRST and tail LAST.
1702    Returns nonzero only if successful.  */
1703 static int
1704 parse_repeating_data (struct dls_var_spec **first, struct dls_var_spec **last)
1705 {
1706   struct fixed_parsing_state fx;
1707   size_t i;
1708
1709   fx.recno = 0;
1710   fx.sc = 1;
1711
1712   while (token != '.')
1713     {
1714       if (!parse_DATA_LIST_vars (&fx.name, &fx.name_cnt, PV_NONE))
1715         return 0;
1716
1717       if (lex_is_number ())
1718         {
1719           if (!fixed_parse_compatible (&fx, first, last))
1720             goto fail;
1721         }
1722       else if (token == '(')
1723         {
1724           if (!fixed_parse_fortran (&fx, first, last))
1725             goto fail;
1726         }
1727       else
1728         {
1729           msg (SE, _("SPSS-like or FORTRAN-like format "
1730                      "specification expected after variable names."));
1731           goto fail;
1732         }
1733
1734       for (i = 0; i < fx.name_cnt; i++)
1735         free (fx.name[i]);
1736       free (fx.name);
1737     }
1738
1739   return 1;
1740
1741  fail:
1742   for (i = 0; i < fx.name_cnt; i++)
1743     free (fx.name[i]);
1744   free (fx.name);
1745   return 0;
1746 }
1747
1748 /* Obtains the real value for rpd_num_or_var N in case C and returns
1749    it.  The valid range is nonnegative numbers, but numbers outside
1750    this range can be returned and should be handled by the caller as
1751    invalid. */
1752 static int
1753 realize_value (struct rpd_num_or_var *n, struct ccase *c)
1754 {
1755   if (n->var != NULL)
1756     {
1757       double v = case_num (c, n->var->fv);
1758       return v != SYSMIS && v >= INT_MIN && v <= INT_MAX ? v : -1;
1759     }
1760   else
1761     return n->num;
1762 }
1763
1764 /* Parameter record passed to rpd_parse_record(). */
1765 struct rpd_parse_info
1766   {
1767     struct repeating_data_trns *trns;  /* REPEATING DATA transformation. */
1768     const char *line;   /* Line being parsed. */
1769     size_t len;         /* Line length. */
1770     int beg, end;       /* First and last column of first occurrence. */
1771     int ofs;            /* Column offset between repeated occurrences. */
1772     struct ccase *c;    /* Case to fill in. */
1773     int verify_id;      /* Zero to initialize ID, nonzero to verify it. */
1774     int max_occurs;     /* Max number of occurrences to parse. */
1775   };
1776
1777 /* Parses one record of repeated data and outputs corresponding
1778    cases.  Returns number of occurrences parsed up to the
1779    maximum specified in INFO. */
1780 static int
1781 rpd_parse_record (const struct rpd_parse_info *info)
1782 {
1783   struct repeating_data_trns *t = info->trns;
1784   int cur = info->beg;
1785   int occurrences;
1786
1787   /* Handle record ID values. */
1788   if (t->id_beg != 0)
1789     {
1790       union value id_temp[MAX_ELEMS_PER_VALUE];
1791
1792       /* Parse record ID into V. */
1793       {
1794         struct data_in di;
1795
1796         data_in_finite_line (&di, info->line, info->len, t->id_beg, t->id_end);
1797         di.v = info->verify_id ? id_temp : t->id_value;
1798         di.flags = 0;
1799         di.f1 = t->id_beg;
1800         di.format = t->id_spec;
1801
1802         if (!data_in (&di))
1803           return 0;
1804       }
1805
1806       if (info->verify_id
1807           && compare_values (id_temp, t->id_value, t->id_var->width) != 0)
1808         {
1809           char expected_str [MAX_FORMATTED_LEN + 1];
1810           char actual_str [MAX_FORMATTED_LEN + 1];
1811
1812           data_out (expected_str, &t->id_var->print, t->id_value);
1813           expected_str[t->id_var->print.w] = '\0';
1814
1815           data_out (actual_str, &t->id_var->print, id_temp);
1816           actual_str[t->id_var->print.w] = '\0';
1817
1818           tmsg (SE, RPD_ERR,
1819                 _("Encountered mismatched record ID \"%s\" expecting \"%s\"."),
1820                 actual_str, expected_str);
1821
1822           return 0;
1823         }
1824     }
1825
1826   /* Iterate over the set of expected occurrences and record each of
1827      them as a separate case.  FIXME: We need to execute any
1828      transformations that follow the current one. */
1829   {
1830     int warned = 0;
1831
1832     for (occurrences = 0; occurrences < info->max_occurs; )
1833       {
1834         if (cur + info->ofs > info->end + 1)
1835           break;
1836         occurrences++;
1837
1838         {
1839           struct dls_var_spec *var_spec = t->first;
1840
1841           for (; var_spec; var_spec = var_spec->next)
1842             {
1843               int fc = var_spec->fc - 1 + cur;
1844               int lc = var_spec->lc - 1 + cur;
1845
1846               if (fc > info->len && !warned && var_spec->input.type != FMT_A)
1847                 {
1848                   warned = 1;
1849
1850                   tmsg (SW, RPD_ERR,
1851                         _("Variable %s starting in column %d extends "
1852                           "beyond physical record length of %d."),
1853                         var_spec->v->name, fc, info->len);
1854                 }
1855
1856               {
1857                 struct data_in di;
1858
1859                 data_in_finite_line (&di, info->line, info->len, fc, lc);
1860                 di.v = case_data_rw (info->c, var_spec->fv);
1861                 di.flags = 0;
1862                 di.f1 = fc + 1;
1863                 di.format = var_spec->input;
1864
1865                 if (!data_in (&di))
1866                   return 0;
1867               }
1868             }
1869         }
1870
1871         cur += info->ofs;
1872
1873         if (!t->write_case (t->wc_data))
1874           return 0;
1875       }
1876   }
1877
1878   return occurrences;
1879 }
1880
1881 /* Reads one set of repetitions of the elements in the REPEATING
1882    DATA structure.  Returns TRNS_CONTINUE on success,
1883    TRNS_DROP_CASE on end of file or on failure, or TRNS_NEXT_CASE. */
1884 int
1885 repeating_data_trns_proc (void *trns_, struct ccase *c, int case_num UNUSED)
1886 {
1887   struct repeating_data_trns *t = trns_;
1888
1889   struct fixed_string line;       /* Current record. */
1890
1891   int starts_beg;       /* Starting column. */
1892   int starts_end;       /* Ending column. */
1893   int occurs;           /* Number of repetitions. */
1894   int length;           /* Length of each occurrence. */
1895   int cont_beg;         /* Starting column for continuation lines. */
1896   int cont_end;         /* Ending column for continuation lines. */
1897
1898   int occurs_left;      /* Number of occurrences remaining. */
1899
1900   int code;             /* Return value from rpd_parse_record(). */
1901
1902   int skip_first_record = 0;
1903
1904   dfm_push (t->reader);
1905
1906   /* Read the current record. */
1907   dfm_reread_record (t->reader, 1);
1908   dfm_expand_tabs (t->reader);
1909   if (dfm_eof (t->reader))
1910     return TRNS_DROP_CASE;
1911   dfm_get_record (t->reader, &line);
1912   dfm_forward_record (t->reader);
1913
1914   /* Calculate occurs, length. */
1915   occurs_left = occurs = realize_value (&t->occurs, c);
1916   if (occurs <= 0)
1917     {
1918       tmsg (SE, RPD_ERR, _("Invalid value %d for OCCURS."), occurs);
1919       return TRNS_NEXT_CASE;
1920     }
1921   starts_beg = realize_value (&t->starts_beg, c);
1922   if (starts_beg <= 0)
1923     {
1924       tmsg (SE, RPD_ERR, _("Beginning column for STARTS (%d) must be "
1925                            "at least 1."),
1926             starts_beg);
1927       return TRNS_NEXT_CASE;
1928     }
1929   starts_end = realize_value (&t->starts_end, c);
1930   if (starts_end < starts_beg)
1931     {
1932       tmsg (SE, RPD_ERR, _("Ending column for STARTS (%d) is less than "
1933                            "beginning column (%d)."),
1934             starts_end, starts_beg);
1935       skip_first_record = 1;
1936     }
1937   length = realize_value (&t->length, c);
1938   if (length < 0)
1939     {
1940       tmsg (SE, RPD_ERR, _("Invalid value %d for LENGTH."), length);
1941       length = 1;
1942       occurs = occurs_left = 1;
1943     }
1944   cont_beg = realize_value (&t->cont_beg, c);
1945   if (cont_beg < 0)
1946     {
1947       tmsg (SE, RPD_ERR, _("Beginning column for CONTINUED (%d) must be "
1948                            "at least 1."),
1949             cont_beg);
1950       return TRNS_DROP_CASE;
1951     }
1952   cont_end = realize_value (&t->cont_end, c);
1953   if (cont_end < cont_beg)
1954     {
1955       tmsg (SE, RPD_ERR, _("Ending column for CONTINUED (%d) is less than "
1956                            "beginning column (%d)."),
1957             cont_end, cont_beg);
1958       return TRNS_DROP_CASE;
1959     }
1960
1961   /* Parse the first record. */
1962   if (!skip_first_record)
1963     {
1964       struct rpd_parse_info info;
1965       info.trns = t;
1966       info.line = ls_c_str (&line);
1967       info.len = ls_length (&line);
1968       info.beg = starts_beg;
1969       info.end = starts_end;
1970       info.ofs = length;
1971       info.c = c;
1972       info.verify_id = 0;
1973       info.max_occurs = occurs_left;
1974       code = rpd_parse_record (&info);
1975       if (!code)
1976         return TRNS_DROP_CASE;
1977       occurs_left -= code;
1978     }
1979   else if (cont_beg == 0)
1980     return TRNS_NEXT_CASE;
1981
1982   /* Make sure, if some occurrences are left, that we have
1983      continuation records. */
1984   if (occurs_left > 0 && cont_beg == 0)
1985     {
1986       tmsg (SE, RPD_ERR,
1987             _("Number of repetitions specified on OCCURS (%d) "
1988               "exceed number of repetitions available in "
1989               "space on STARTS (%d), and CONTINUED not specified."),
1990             occurs, (starts_end - starts_beg + 1) / length);
1991       return TRNS_DROP_CASE;
1992     }
1993
1994   /* Go on to additional records. */
1995   while (occurs_left != 0)
1996     {
1997       struct rpd_parse_info info;
1998
1999       assert (occurs_left >= 0);
2000
2001       /* Read in another record. */
2002       if (dfm_eof (t->reader))
2003         {
2004           tmsg (SE, RPD_ERR,
2005                 _("Unexpected end of file with %d repetitions "
2006                   "remaining out of %d."),
2007                 occurs_left, occurs);
2008           return TRNS_DROP_CASE;
2009         }
2010       dfm_expand_tabs (t->reader);
2011       dfm_get_record (t->reader, &line);
2012       dfm_forward_record (t->reader);
2013
2014       /* Parse this record. */
2015       info.trns = t;
2016       info.line = ls_c_str (&line);
2017       info.len = ls_length (&line);
2018       info.beg = cont_beg;
2019       info.end = cont_end;
2020       info.ofs = length;
2021       info.c = c;
2022       info.verify_id = 1;
2023       info.max_occurs = occurs_left;
2024       code = rpd_parse_record (&info);;
2025       if (!code)
2026         return TRNS_DROP_CASE;
2027       occurs_left -= code;
2028     }
2029
2030   dfm_pop (t->reader);
2031
2032   /* FIXME: This is a kluge until we've implemented multiplexing of
2033      transformations. */
2034   return TRNS_NEXT_CASE;
2035 }
2036
2037 /* Frees a REPEATING DATA transformation.
2038    Returns true if successful, false if an I/O error occurred. */
2039 bool
2040 repeating_data_trns_free (void *rpd_)
2041 {
2042   struct repeating_data_trns *rpd = rpd_;
2043
2044   destroy_dls_var_spec (rpd->first);
2045   dfm_close_reader (rpd->reader);
2046   free (rpd->id_value);
2047   free (rpd);
2048   return true;
2049 }
2050
2051 /* Lets repeating_data_trns_proc() know how to write the cases
2052    that it composes.  Not elegant. */
2053 void
2054 repeating_data_set_write_case (struct transformation *trns_,
2055                                write_case_func *write_case,
2056                                write_case_data wc_data)
2057 {
2058   struct repeating_data_trns *t = trns_->private;
2059
2060   assert (trns_->proc == repeating_data_trns_proc);
2061   t->write_case = write_case;
2062   t->wc_data = wc_data;
2063 }