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