src/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 "data-list.h"
  22 #include "error.h"
  23 #include <ctype.h>
  24 #include <float.h>
  25 #include <stdio.h>
  26 #include <stdlib.h>
  27 #include "alloc.h"
  28 #include "case.h"
  29 #include "command.h"
  30 #include "data-in.h"
  31 #include "debug-print.h"
  32 #include "dfm-read.h"
  33 #include "dictionary.h"
  34 #include "error.h"
  35 #include "file-handle.h"
  36 #include "format.h"
  37 #include "lexer.h"
  38 #include "misc.h"
  39 #include "settings.h"
  40 #include "str.h"
  41 #include "tab.h"
  42 #include "var.h"
  43 #include "vfm.h"
  44
  45 #include "gettext.h"
  46 #define _(msgid) gettext (msgid)
  47 \f
  48 /* Utility function. */
  49
  50 /* FIXME: Either REPEATING DATA must be the last transformation, or we
  51    must multiplex the transformations that follow (i.e., perform them
  52    for every case that we produce from a repetition instance).
  53    Currently we do neither.  We should do one or the other. */
  54
  55 /* Describes how to parse one variable. */
  56 struct dls_var_spec
  57   {
  58     struct dls_var_spec *next;  /* Next specification in list. */
  59
  60     /* Both free and fixed formats. */
  61     struct fmt_spec input;      /* Input format of this field. */
  62     struct variable *v;         /* Associated variable.  Used only in
  63                                    parsing.  Not safe later. */
  64     int fv;                     /* First value in case. */
  65
  66     /* Fixed format only. */
  67     int rec;                    /* Record number (1-based). */
  68     int fc, lc;                 /* Column numbers in record. */
  69
  70     /* Free format only. */
  71     char name[LONG_NAME_LEN + 1]; /* Name of variable. */
  72   };
  73
  74 /* Constants for DATA LIST type. */
  75 /* Must match table in cmd_data_list(). */
  76 enum
  77   {
  78     DLS_FIXED,
  79     DLS_FREE,
  80     DLS_LIST
  81   };
  82
  83 /* DATA LIST private data structure. */
  84 struct data_list_pgm
  85   {
  86     struct dls_var_spec *first, *last;  /* Variable parsing specifications. */
  87     struct dfm_reader *reader;  /* Data file reader. */
  88
  89     int type;                   /* A DLS_* constant. */
  90     struct variable *end;       /* Variable specified on END subcommand. */
  91     int eof;                    /* End of file encountered. */
  92     int rec_cnt;                /* Number of records. */
  93     size_t case_size;           /* Case size in bytes. */
  94     char *delims;               /* Delimiters if any; not null-terminated. */
  95     size_t delim_cnt;           /* Number of delimiter, or 0 for spaces. */
  96   };
  97
  98 static const struct case_source_class data_list_source_class;
  99
 100 static int parse_fixed (struct data_list_pgm *);
 101 static int parse_free (struct dls_var_spec **, struct dls_var_spec **);
 102 static void dump_fixed_table (const struct dls_var_spec *,
 103                               const struct file_handle *, int rec_cnt);
 104 static void dump_free_table (const struct data_list_pgm *,
 105                              const struct file_handle *);
 106 static void destroy_dls_var_spec (struct dls_var_spec *);
 107 static trns_free_func data_list_trns_free;
 108 static trns_proc_func data_list_trns_proc;
 109
 110 /* Message title for REPEATING DATA. */
 111 #define RPD_ERR "REPEATING DATA: "
 112
 113 int
 114 cmd_data_list (void)
 115 {
 116   struct data_list_pgm *dls;
 117   int table = -1;                /* Print table if nonzero, -1=undecided. */
 118   struct file_handle *fh = fh_inline_file ();
 119
 120   if (!case_source_is_complex (vfm_source))
 121     discard_variables ();
 122
 123   dls = xmalloc (sizeof *dls);
 124   dls->reader = NULL;
 125   dls->type = -1;
 126   dls->end = NULL;
 127   dls->eof = 0;
 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_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 | TAT_FIX,
 797                     fmt_to_string (&spec->input));
 798     }
 799
 800   tab_title (t, 1, 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 | TAT_FIX, fmt_to_string (&spec->input));
 913       }
 914   }
 915
 916   tab_title (t, 1, _("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 typedef int data_list_read_func (const struct data_list_pgm *, struct ccase *);
1031 static data_list_read_func read_from_data_list_fixed;
1032 static data_list_read_func read_from_data_list_free;
1033 static data_list_read_func read_from_data_list_list;
1034
1035 /* Returns the proper function to read the kind of DATA LIST
1036    data specified by DLS. */
1037 static data_list_read_func *
1038 get_data_list_read_func (const struct data_list_pgm *dls)
1039 {
1040   switch (dls->type)
1041     {
1042     case DLS_FIXED:
1043       return read_from_data_list_fixed;
1044
1045     case DLS_FREE:
1046       return read_from_data_list_free;
1047
1048     case DLS_LIST:
1049       return read_from_data_list_list;
1050
1051     default:
1052       assert (0);
1053       abort ();
1054     }
1055 }
1056
1057 /* Reads a case from the data file into C, parsing it according
1058    to fixed-format syntax rules in DLS.  Returns -1 on success,
1059    -2 at end of file. */
1060 static int
1061 read_from_data_list_fixed (const struct data_list_pgm *dls,
1062                            struct ccase *c)
1063 {
1064   struct dls_var_spec *var_spec = dls->first;
1065   int i;
1066
1067   if (dfm_eof (dls->reader))
1068     return -2;
1069   for (i = 1; i <= dls->rec_cnt; i++)
1070     {
1071       struct fixed_string line;
1072
1073       if (dfm_eof (dls->reader))
1074         {
1075           /* Note that this can't occur on the first record. */
1076           msg (SW, _("Partial case of %d of %d records discarded."),
1077                i - 1, dls->rec_cnt);
1078           return -2;
1079         }
1080       dfm_expand_tabs (dls->reader);
1081       dfm_get_record (dls->reader, &line);
1082
1083       for (; var_spec && i == var_spec->rec; var_spec = var_spec->next)
1084         {
1085           struct data_in di;
1086
1087           data_in_finite_line (&di, ls_c_str (&line), ls_length (&line),
1088                                var_spec->fc, var_spec->lc);
1089           di.v = case_data_rw (c, var_spec->fv);
1090           di.flags = DI_IMPLIED_DECIMALS;
1091           di.f1 = var_spec->fc;
1092           di.format = var_spec->input;
1093
1094           data_in (&di);
1095         }
1096
1097       dfm_forward_record (dls->reader);
1098     }
1099
1100   return -1;
1101 }
1102
1103 /* Reads a case from the data file into C, parsing it according
1104    to free-format syntax rules in DLS.  Returns -1 on success,
1105    -2 at end of file. */
1106 static int
1107 read_from_data_list_free (const struct data_list_pgm *dls,
1108                           struct ccase *c)
1109 {
1110   struct dls_var_spec *var_spec;
1111   int end_blank = 0;
1112
1113   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1114     {
1115       struct fixed_string field;
1116       int column;
1117
1118       /* Cut out a field and read in a new record if necessary. */
1119       for (;;)
1120         {
1121           column = cut_field (dls, &field, &end_blank);
1122           if (column != 0)
1123             break;
1124
1125           if (!dfm_eof (dls->reader))
1126             dfm_forward_record (dls->reader);
1127           if (dfm_eof (dls->reader))
1128             {
1129               if (var_spec != dls->first)
1130                 msg (SW, _("Partial case discarded.  The first variable "
1131                            "missing was %s."), var_spec->name);
1132               return -2;
1133             }
1134         }
1135
1136       {
1137         struct data_in di;
1138
1139         di.s = ls_c_str (&field);
1140         di.e = ls_end (&field);
1141         di.v = case_data_rw (c, var_spec->fv);
1142         di.flags = 0;
1143         di.f1 = column;
1144         di.format = var_spec->input;
1145         data_in (&di);
1146       }
1147     }
1148   return -1;
1149 }
1150
1151 /* Reads a case from the data file and parses it according to
1152    list-format syntax rules.  Returns -1 on success, -2 at end of
1153    file. */
1154 static int
1155 read_from_data_list_list (const struct data_list_pgm *dls,
1156                           struct ccase *c)
1157 {
1158   struct dls_var_spec *var_spec;
1159   int end_blank = 0;
1160
1161   if (dfm_eof (dls->reader))
1162     return -2;
1163
1164   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1165     {
1166       struct fixed_string field;
1167       int column;
1168
1169       /* Cut out a field and check for end-of-line. */
1170       column = cut_field (dls, &field, &end_blank);
1171       if (column == 0)
1172         {
1173           if (get_undefined ())
1174             msg (SW, _("Missing value(s) for all variables from %s onward.  "
1175                        "These will be filled with the system-missing value "
1176                        "or blanks, as appropriate."),
1177                  var_spec->name);
1178           for (; var_spec; var_spec = var_spec->next)
1179             {
1180               int width = get_format_var_width (&var_spec->input);
1181               if (width == 0)
1182                 case_data_rw (c, var_spec->fv)->f = SYSMIS;
1183               else
1184                 memset (case_data_rw (c, var_spec->fv)->s, ' ', width);
1185             }
1186           break;
1187         }
1188
1189       {
1190         struct data_in di;
1191
1192         di.s = ls_c_str (&field);
1193         di.e = ls_end (&field);
1194         di.v = case_data_rw (c, var_spec->fv);
1195         di.flags = 0;
1196         di.f1 = column;
1197         di.format = var_spec->input;
1198         data_in (&di);
1199       }
1200     }
1201
1202   dfm_forward_record (dls->reader);
1203   return -1;
1204 }
1205
1206 /* Destroys SPEC. */
1207 static void
1208 destroy_dls_var_spec (struct dls_var_spec *spec)
1209 {
1210   struct dls_var_spec *next;
1211
1212   while (spec != NULL)
1213     {
1214       next = spec->next;
1215       free (spec);
1216       spec = next;
1217     }
1218 }
1219
1220 /* Destroys DATA LIST transformation DLS. */
1221 static void
1222 data_list_trns_free (void *dls_)
1223 {
1224   struct data_list_pgm *dls = dls_;
1225   free (dls->delims);
1226   destroy_dls_var_spec (dls->first);
1227   dfm_close_reader (dls->reader);
1228   free (dls);
1229 }
1230
1231 /* Handle DATA LIST transformation DLS, parsing data into C. */
1232 static int
1233 data_list_trns_proc (void *dls_, struct ccase *c, int case_num UNUSED)
1234 {
1235   struct data_list_pgm *dls = dls_;
1236   data_list_read_func *read_func;
1237   int retval;
1238
1239   dfm_push (dls->reader);
1240
1241   read_func = get_data_list_read_func (dls);
1242   retval = read_func (dls, c);
1243
1244   /* Handle end of file. */
1245   if (retval == -2)
1246     {
1247       /* If we already encountered end of file then this is an
1248          error. */
1249       if (dls->eof == 1)
1250         {
1251           msg (SE, _("Attempt to read past end of file."));
1252           err_failure ();
1253           dfm_pop (dls->reader);
1254           return -2;
1255         }
1256
1257       /* Otherwise simply note it. */
1258       dls->eof = 1;
1259     }
1260   else
1261     dls->eof = 0;
1262
1263   /* If there was an END subcommand handle it. */
1264   if (dls->end != NULL)
1265     {
1266       if (retval == -2)
1267         {
1268           case_data_rw (c, dls->end->fv)->f = 1.0;
1269           retval = -1;
1270         }
1271       else
1272         case_data_rw (c, dls->end->fv)->f = 0.0;
1273     }
1274
1275   dfm_pop (dls->reader);
1276
1277   return retval;
1278 }
1279 \f
1280 /* Reads all the records from the data file and passes them to
1281    write_case(). */
1282 static void
1283 data_list_source_read (struct case_source *source,
1284                        struct ccase *c,
1285                        write_case_func *write_case, write_case_data wc_data)
1286 {
1287   struct data_list_pgm *dls = source->aux;
1288   data_list_read_func *read_func = get_data_list_read_func (dls);
1289
1290   dfm_push (dls->reader);
1291   while (read_func (dls, c) != -2)
1292     if (!write_case (wc_data))
1293       break;
1294   dfm_pop (dls->reader);
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 /* Parses the REPEATING DATA command. */
1352 int
1353 cmd_repeating_data (void)
1354 {
1355   struct repeating_data_trns *rpd;
1356   int table = 1;                /* Print table? */
1357   bool saw_starts = false;      /* Saw STARTS subcommand? */
1358   bool saw_occurs = false;      /* Saw OCCURS subcommand? */
1359   bool saw_length = false;      /* Saw LENGTH subcommand? */
1360   bool saw_continued = false;   /* Saw CONTINUED subcommand? */
1361   bool saw_id = false;          /* Saw ID subcommand? */
1362   struct file_handle *const fh = fh_get_default_handle ();
1363
1364   assert (case_source_is_complex (vfm_source));
1365
1366   rpd = xmalloc (sizeof *rpd);
1367   rpd->reader = dfm_open_reader (fh);
1368   rpd->first = rpd->last = NULL;
1369   rpd->starts_beg.num = 0;
1370   rpd->starts_beg.var = NULL;
1371   rpd->starts_end = rpd->occurs = rpd->length = rpd->cont_beg
1372     = rpd->cont_end = rpd->starts_beg;
1373   rpd->id_beg = rpd->id_end = 0;
1374   rpd->id_var = NULL;
1375   rpd->id_value = NULL;
1376
1377   lex_match ('/');
1378
1379   for (;;)
1380     {
1381       if (lex_match_id ("FILE"))
1382         {
1383           struct file_handle *file;
1384           lex_match ('=');
1385           file = fh_parse (FH_REF_FILE | FH_REF_INLINE);
1386           if (file == NULL)
1387             goto error;
1388           if (file != fh)
1389             {
1390               msg (SE, _("REPEATING DATA must use the same file as its "
1391                          "corresponding DATA LIST or FILE TYPE."));
1392               goto error;
1393             }
1394         }
1395       else if (lex_match_id ("STARTS"))
1396         {
1397           lex_match ('=');
1398           if (saw_starts)
1399             {
1400               msg (SE, _("%s subcommand given multiple times."),"STARTS");
1401               goto error;
1402             }
1403           saw_starts = true;
1404
1405           if (!parse_num_or_var (&rpd->starts_beg, "STARTS beginning column"))
1406             goto error;
1407
1408           lex_negative_to_dash ();
1409           if (lex_match ('-'))
1410             {
1411               if (!parse_num_or_var (&rpd->starts_end, "STARTS ending column"))
1412                 goto error;
1413             } else {
1414               /* Otherwise, rpd->starts_end is uninitialized.  We
1415                  will initialize it later from the record length
1416                  of the file.  We can't do so now because the
1417                  file handle may not be specified yet. */
1418             }
1419
1420           if (rpd->starts_beg.num != 0 && rpd->starts_end.num != 0
1421               && rpd->starts_beg.num > rpd->starts_end.num)
1422             {
1423               msg (SE, _("STARTS beginning column (%d) exceeds "
1424                          "STARTS ending column (%d)."),
1425                    rpd->starts_beg.num, rpd->starts_end.num);
1426               goto error;
1427             }
1428         }
1429       else if (lex_match_id ("OCCURS"))
1430         {
1431           lex_match ('=');
1432           if (saw_occurs)
1433             {
1434               msg (SE, _("%s subcommand given multiple times."),"OCCURS");
1435               goto error;
1436             }
1437           saw_occurs = true;
1438
1439           if (!parse_num_or_var (&rpd->occurs, "OCCURS"))
1440             goto error;
1441         }
1442       else if (lex_match_id ("LENGTH"))
1443         {
1444           lex_match ('=');
1445           if (saw_length)
1446             {
1447               msg (SE, _("%s subcommand given multiple times."),"LENGTH");
1448               goto error;
1449             }
1450           saw_length = true;
1451
1452           if (!parse_num_or_var (&rpd->length, "LENGTH"))
1453             goto error;
1454         }
1455       else if (lex_match_id ("CONTINUED"))
1456         {
1457           lex_match ('=');
1458           if (saw_continued)
1459             {
1460               msg (SE, _("%s subcommand given multiple times."),"CONTINUED");
1461               goto error;
1462             }
1463           saw_continued = true;
1464
1465           if (!lex_match ('/'))
1466             {
1467               if (!parse_num_or_var (&rpd->cont_beg,
1468                                      "CONTINUED beginning column"))
1469                 goto error;
1470
1471               lex_negative_to_dash ();
1472               if (lex_match ('-')
1473                   && !parse_num_or_var (&rpd->cont_end,
1474                                         "CONTINUED ending column"))
1475                 goto error;
1476
1477               if (rpd->cont_beg.num != 0 && rpd->cont_end.num != 0
1478                   && rpd->cont_beg.num > rpd->cont_end.num)
1479                 {
1480                   msg (SE, _("CONTINUED beginning column (%d) exceeds "
1481                              "CONTINUED ending column (%d)."),
1482                        rpd->cont_beg.num, rpd->cont_end.num);
1483                   goto error;
1484                 }
1485             }
1486           else
1487             rpd->cont_beg.num = 1;
1488         }
1489       else if (lex_match_id ("ID"))
1490         {
1491           lex_match ('=');
1492           if (saw_id)
1493             {
1494               msg (SE, _("%s subcommand given multiple times."),"ID");
1495               goto error;
1496             }
1497           saw_id = true;
1498
1499           if (!lex_force_int ())
1500             goto error;
1501           if (lex_integer () < 1)
1502             {
1503               msg (SE, _("ID beginning column (%ld) must be positive."),
1504                    lex_integer ());
1505               goto error;
1506             }
1507           rpd->id_beg = lex_integer ();
1508
1509           lex_get ();
1510           lex_negative_to_dash ();
1511
1512           if (lex_match ('-'))
1513             {
1514               if (!lex_force_int ())
1515                 goto error;
1516               if (lex_integer () < 1)
1517                 {
1518                   msg (SE, _("ID ending column (%ld) must be positive."),
1519                        lex_integer ());
1520                   goto error;
1521                 }
1522               if (lex_integer () < rpd->id_end)
1523                 {
1524                   msg (SE, _("ID ending column (%ld) cannot be less than "
1525                              "ID beginning column (%d)."),
1526                        lex_integer (), rpd->id_beg);
1527                   goto error;
1528                 }
1529
1530               rpd->id_end = lex_integer ();
1531               lex_get ();
1532             }
1533           else rpd->id_end = rpd->id_beg;
1534
1535           if (!lex_force_match ('='))
1536             goto error;
1537           rpd->id_var = parse_variable ();
1538           if (rpd->id_var == NULL)
1539             goto error;
1540
1541           find_variable_input_spec (rpd->id_var, &rpd->id_spec);
1542           rpd->id_value = xnmalloc (rpd->id_var->nv, sizeof *rpd->id_value);
1543         }
1544       else if (lex_match_id ("TABLE"))
1545         table = 1;
1546       else if (lex_match_id ("NOTABLE"))
1547         table = 0;
1548       else if (lex_match_id ("DATA"))
1549         break;
1550       else
1551         {
1552           lex_error (NULL);
1553           goto error;
1554         }
1555
1556       if (!lex_force_match ('/'))
1557         goto error;
1558     }
1559
1560   /* Comes here when DATA specification encountered. */
1561   if (!saw_starts || !saw_occurs)
1562     {
1563       if (!saw_starts)
1564         msg (SE, _("Missing required specification STARTS."));
1565       if (!saw_occurs)
1566         msg (SE, _("Missing required specification OCCURS."));
1567       goto error;
1568     }
1569
1570   /* Enforce ID restriction. */
1571   if (saw_id && !saw_continued)
1572     {
1573       msg (SE, _("ID specified without CONTINUED."));
1574       goto error;
1575     }
1576
1577   /* Calculate and check starts_end, cont_end if necessary. */
1578   if (rpd->starts_end.num == 0 && rpd->starts_end.var == NULL)
1579     {
1580       rpd->starts_end.num = fh_get_record_width (fh);
1581       if (rpd->starts_beg.num != 0
1582           && rpd->starts_beg.num > rpd->starts_end.num)
1583         {
1584           msg (SE, _("STARTS beginning column (%d) exceeds "
1585                      "default STARTS ending column taken from file's "
1586                      "record width (%d)."),
1587                rpd->starts_beg.num, rpd->starts_end.num);
1588           goto error;
1589         }
1590     }
1591   if (rpd->cont_end.num == 0 && rpd->cont_end.var == NULL)
1592     {
1593       rpd->cont_end.num = fh_get_record_width (fh);
1594       if (rpd->cont_beg.num != 0
1595           && rpd->cont_beg.num > rpd->cont_end.num)
1596         {
1597           msg (SE, _("CONTINUED beginning column (%d) exceeds "
1598                      "default CONTINUED ending column taken from file's "
1599                      "record width (%d)."),
1600                rpd->cont_beg.num, rpd->cont_end.num);
1601           goto error;
1602         }
1603     }
1604
1605   lex_match ('=');
1606   if (!parse_repeating_data (&rpd->first, &rpd->last))
1607     goto error;
1608
1609   /* Calculate length if necessary. */
1610   if (!saw_length)
1611     {
1612       struct dls_var_spec *iter;
1613
1614       for (iter = rpd->first; iter; iter = iter->next)
1615         if (iter->lc > rpd->length.num)
1616           rpd->length.num = iter->lc;
1617       assert (rpd->length.num != 0);
1618     }
1619
1620   if (table)
1621     dump_fixed_table (rpd->first, fh, rpd->last->rec);
1622
1623   add_transformation (repeating_data_trns_proc, repeating_data_trns_free, rpd);
1624
1625   return lex_end_of_command ();
1626
1627  error:
1628   repeating_data_trns_free (rpd);
1629   return CMD_FAILURE;
1630 }
1631
1632 /* Finds the input format specification for variable V and puts
1633    it in SPEC.  Because of the way that DATA LIST is structured,
1634    this is nontrivial. */
1635 static void
1636 find_variable_input_spec (struct variable *v, struct fmt_spec *spec)
1637 {
1638   size_t i;
1639
1640   for (i = 0; i < n_trns; i++)
1641     {
1642       struct transformation *trns = &t_trns[i];
1643
1644       if (trns->proc == data_list_trns_proc)
1645         {
1646           struct data_list_pgm *pgm = trns->private;
1647           struct dls_var_spec *iter;
1648
1649           for (iter = pgm->first; iter; iter = iter->next)
1650             if (iter->v == v)
1651               {
1652                 *spec = iter->input;
1653                 return;
1654               }
1655         }
1656     }
1657
1658   assert (0);
1659 }
1660
1661 /* Parses a number or a variable name from the syntax file and puts
1662    the results in VALUE.  Ensures that the number is at least 1; else
1663    emits an error based on MESSAGE.  Returns nonzero only if
1664    successful. */
1665 static int
1666 parse_num_or_var (struct rpd_num_or_var *value, const char *message)
1667 {
1668   if (token == T_ID)
1669     {
1670       value->num = 0;
1671       value->var = parse_variable ();
1672       if (value->var == NULL)
1673         return 0;
1674       if (value->var->type == ALPHA)
1675         {
1676           msg (SE, _("String variable not allowed here."));
1677           return 0;
1678         }
1679     }
1680   else if (lex_is_integer ())
1681     {
1682       value->num = lex_integer ();
1683
1684       if (value->num < 1)
1685         {
1686           msg (SE, _("%s (%d) must be at least 1."), message, value->num);
1687           return 0;
1688         }
1689
1690       lex_get ();
1691     } else {
1692       msg (SE, _("Variable or integer expected for %s."), message);
1693       return 0;
1694     }
1695   return 1;
1696 }
1697
1698 /* Parses data specifications for repeating data groups, adding
1699    them to the linked list with head FIRST and tail LAST.
1700    Returns nonzero only if successful.  */
1701 static int
1702 parse_repeating_data (struct dls_var_spec **first, struct dls_var_spec **last)
1703 {
1704   struct fixed_parsing_state fx;
1705   size_t i;
1706
1707   fx.recno = 0;
1708   fx.sc = 1;
1709
1710   while (token != '.')
1711     {
1712       if (!parse_DATA_LIST_vars (&fx.name, &fx.name_cnt, PV_NONE))
1713         return 0;
1714
1715       if (lex_is_number ())
1716         {
1717           if (!fixed_parse_compatible (&fx, first, last))
1718             goto fail;
1719         }
1720       else if (token == '(')
1721         {
1722           if (!fixed_parse_fortran (&fx, first, last))
1723             goto fail;
1724         }
1725       else
1726         {
1727           msg (SE, _("SPSS-like or FORTRAN-like format "
1728                      "specification expected after variable names."));
1729           goto fail;
1730         }
1731
1732       for (i = 0; i < fx.name_cnt; i++)
1733         free (fx.name[i]);
1734       free (fx.name);
1735     }
1736
1737   return 1;
1738
1739  fail:
1740   for (i = 0; i < fx.name_cnt; i++)
1741     free (fx.name[i]);
1742   free (fx.name);
1743   return 0;
1744 }
1745
1746 /* Obtains the real value for rpd_num_or_var N in case C and returns
1747    it.  The valid range is nonnegative numbers, but numbers outside
1748    this range can be returned and should be handled by the caller as
1749    invalid. */
1750 static int
1751 realize_value (struct rpd_num_or_var *n, struct ccase *c)
1752 {
1753   if (n->var != NULL)
1754     {
1755       double v = case_num (c, n->var->fv);
1756       return v != SYSMIS && v >= INT_MIN && v <= INT_MAX ? v : -1;
1757     }
1758   else
1759     return n->num;
1760 }
1761
1762 /* Parameter record passed to rpd_parse_record(). */
1763 struct rpd_parse_info
1764   {
1765     struct repeating_data_trns *trns;  /* REPEATING DATA transformation. */
1766     const char *line;   /* Line being parsed. */
1767     size_t len;         /* Line length. */
1768     int beg, end;       /* First and last column of first occurrence. */
1769     int ofs;            /* Column offset between repeated occurrences. */
1770     struct ccase *c;    /* Case to fill in. */
1771     int verify_id;      /* Zero to initialize ID, nonzero to verify it. */
1772     int max_occurs;     /* Max number of occurrences to parse. */
1773   };
1774
1775 /* Parses one record of repeated data and outputs corresponding
1776    cases.  Returns number of occurrences parsed up to the
1777    maximum specified in INFO. */
1778 static int
1779 rpd_parse_record (const struct rpd_parse_info *info)
1780 {
1781   struct repeating_data_trns *t = info->trns;
1782   int cur = info->beg;
1783   int occurrences;
1784
1785   /* Handle record ID values. */
1786   if (t->id_beg != 0)
1787     {
1788       union value id_temp[MAX_ELEMS_PER_VALUE];
1789
1790       /* Parse record ID into V. */
1791       {
1792         struct data_in di;
1793
1794         data_in_finite_line (&di, info->line, info->len, t->id_beg, t->id_end);
1795         di.v = info->verify_id ? id_temp : t->id_value;
1796         di.flags = 0;
1797         di.f1 = t->id_beg;
1798         di.format = t->id_spec;
1799
1800         if (!data_in (&di))
1801           return 0;
1802       }
1803
1804       if (info->verify_id
1805           && compare_values (id_temp, t->id_value, t->id_var->width) != 0)
1806         {
1807           char expected_str [MAX_FORMATTED_LEN + 1];
1808           char actual_str [MAX_FORMATTED_LEN + 1];
1809
1810           data_out (expected_str, &t->id_var->print, t->id_value);
1811           expected_str[t->id_var->print.w] = '\0';
1812
1813           data_out (actual_str, &t->id_var->print, id_temp);
1814           actual_str[t->id_var->print.w] = '\0';
1815
1816           tmsg (SE, RPD_ERR,
1817                 _("Encountered mismatched record ID \"%s\" expecting \"%s\"."),
1818                 actual_str, expected_str);
1819
1820           return 0;
1821         }
1822     }
1823
1824   /* Iterate over the set of expected occurrences and record each of
1825      them as a separate case.  FIXME: We need to execute any
1826      transformations that follow the current one. */
1827   {
1828     int warned = 0;
1829
1830     for (occurrences = 0; occurrences < info->max_occurs; )
1831       {
1832         if (cur + info->ofs > info->end + 1)
1833           break;
1834         occurrences++;
1835
1836         {
1837           struct dls_var_spec *var_spec = t->first;
1838
1839           for (; var_spec; var_spec = var_spec->next)
1840             {
1841               int fc = var_spec->fc - 1 + cur;
1842               int lc = var_spec->lc - 1 + cur;
1843
1844               if (fc > info->len && !warned && var_spec->input.type != FMT_A)
1845                 {
1846                   warned = 1;
1847
1848                   tmsg (SW, RPD_ERR,
1849                         _("Variable %s starting in column %d extends "
1850                           "beyond physical record length of %d."),
1851                         var_spec->v->name, fc, info->len);
1852                 }
1853
1854               {
1855                 struct data_in di;
1856
1857                 data_in_finite_line (&di, info->line, info->len, fc, lc);
1858                 di.v = case_data_rw (info->c, var_spec->fv);
1859                 di.flags = 0;
1860                 di.f1 = fc + 1;
1861                 di.format = var_spec->input;
1862
1863                 if (!data_in (&di))
1864                   return 0;
1865               }
1866             }
1867         }
1868
1869         cur += info->ofs;
1870
1871         if (!t->write_case (t->wc_data))
1872           return 0;
1873       }
1874   }
1875
1876   return occurrences;
1877 }
1878
1879 /* Reads one set of repetitions of the elements in the REPEATING
1880    DATA structure.  Returns -1 on success, -2 on end of file or
1881    on failure. */
1882 int
1883 repeating_data_trns_proc (void *trns_, struct ccase *c, int case_num UNUSED)
1884 {
1885   struct repeating_data_trns *t = trns_;
1886
1887   struct fixed_string line;       /* Current record. */
1888
1889   int starts_beg;       /* Starting column. */
1890   int starts_end;       /* Ending column. */
1891   int occurs;           /* Number of repetitions. */
1892   int length;           /* Length of each occurrence. */
1893   int cont_beg;         /* Starting column for continuation lines. */
1894   int cont_end;         /* Ending column for continuation lines. */
1895
1896   int occurs_left;      /* Number of occurrences remaining. */
1897
1898   int code;             /* Return value from rpd_parse_record(). */
1899
1900   int skip_first_record = 0;
1901
1902   dfm_push (t->reader);
1903
1904   /* Read the current record. */
1905   dfm_reread_record (t->reader, 1);
1906   dfm_expand_tabs (t->reader);
1907   if (dfm_eof (t->reader))
1908     return -2;
1909   dfm_get_record (t->reader, &line);
1910   dfm_forward_record (t->reader);
1911
1912   /* Calculate occurs, length. */
1913   occurs_left = occurs = realize_value (&t->occurs, c);
1914   if (occurs <= 0)
1915     {
1916       tmsg (SE, RPD_ERR, _("Invalid value %d for OCCURS."), occurs);
1917       return -3;
1918     }
1919   starts_beg = realize_value (&t->starts_beg, c);
1920   if (starts_beg <= 0)
1921     {
1922       tmsg (SE, RPD_ERR, _("Beginning column for STARTS (%d) must be "
1923                            "at least 1."),
1924             starts_beg);
1925       return -3;
1926     }
1927   starts_end = realize_value (&t->starts_end, c);
1928   if (starts_end < starts_beg)
1929     {
1930       tmsg (SE, RPD_ERR, _("Ending column for STARTS (%d) is less than "
1931                            "beginning column (%d)."),
1932             starts_end, starts_beg);
1933       skip_first_record = 1;
1934     }
1935   length = realize_value (&t->length, c);
1936   if (length < 0)
1937     {
1938       tmsg (SE, RPD_ERR, _("Invalid value %d for LENGTH."), length);
1939       length = 1;
1940       occurs = occurs_left = 1;
1941     }
1942   cont_beg = realize_value (&t->cont_beg, c);
1943   if (cont_beg < 0)
1944     {
1945       tmsg (SE, RPD_ERR, _("Beginning column for CONTINUED (%d) must be "
1946                            "at least 1."),
1947             cont_beg);
1948       return -2;
1949     }
1950   cont_end = realize_value (&t->cont_end, c);
1951   if (cont_end < cont_beg)
1952     {
1953       tmsg (SE, RPD_ERR, _("Ending column for CONTINUED (%d) is less than "
1954                            "beginning column (%d)."),
1955             cont_end, cont_beg);
1956       return -2;
1957     }
1958
1959   /* Parse the first record. */
1960   if (!skip_first_record)
1961     {
1962       struct rpd_parse_info info;
1963       info.trns = t;
1964       info.line = ls_c_str (&line);
1965       info.len = ls_length (&line);
1966       info.beg = starts_beg;
1967       info.end = starts_end;
1968       info.ofs = length;
1969       info.c = c;
1970       info.verify_id = 0;
1971       info.max_occurs = occurs_left;
1972       code = rpd_parse_record (&info);
1973       if (!code)
1974         return -2;
1975       occurs_left -= code;
1976     }
1977   else if (cont_beg == 0)
1978     return -3;
1979
1980   /* Make sure, if some occurrences are left, that we have
1981      continuation records. */
1982   if (occurs_left > 0 && cont_beg == 0)
1983     {
1984       tmsg (SE, RPD_ERR,
1985             _("Number of repetitions specified on OCCURS (%d) "
1986               "exceed number of repetitions available in "
1987               "space on STARTS (%d), and CONTINUED not specified."),
1988             occurs, (starts_end - starts_beg + 1) / length);
1989       return -2;
1990     }
1991
1992   /* Go on to additional records. */
1993   while (occurs_left != 0)
1994     {
1995       struct rpd_parse_info info;
1996
1997       assert (occurs_left >= 0);
1998
1999       /* Read in another record. */
2000       if (dfm_eof (t->reader))
2001         {
2002           tmsg (SE, RPD_ERR,
2003                 _("Unexpected end of file with %d repetitions "
2004                   "remaining out of %d."),
2005                 occurs_left, occurs);
2006           return -2;
2007         }
2008       dfm_expand_tabs (t->reader);
2009       dfm_get_record (t->reader, &line);
2010       dfm_forward_record (t->reader);
2011
2012       /* Parse this record. */
2013       info.trns = t;
2014       info.line = ls_c_str (&line);
2015       info.len = ls_length (&line);
2016       info.beg = cont_beg;
2017       info.end = cont_end;
2018       info.ofs = length;
2019       info.c = c;
2020       info.verify_id = 1;
2021       info.max_occurs = occurs_left;
2022       code = rpd_parse_record (&info);;
2023       if (!code)
2024         return -2;
2025       occurs_left -= code;
2026     }
2027
2028   dfm_pop (t->reader);
2029
2030   /* FIXME: This is a kluge until we've implemented multiplexing of
2031      transformations. */
2032   return -3;
2033 }
2034
2035 /* Frees a REPEATING DATA transformation. */
2036 void
2037 repeating_data_trns_free (void *rpd_)
2038 {
2039   struct repeating_data_trns *rpd = rpd_;
2040
2041   destroy_dls_var_spec (rpd->first);
2042   dfm_close_reader (rpd->reader);
2043   free (rpd->id_value);
2044   free (rpd);
2045 }
2046
2047 /* Lets repeating_data_trns_proc() know how to write the cases
2048    that it composes.  Not elegant. */
2049 void
2050 repeating_data_set_write_case (struct transformation *trns_,
2051                                write_case_func *write_case,
2052                                write_case_data wc_data)
2053 {
2054   struct repeating_data_trns *t = trns_->private;
2055
2056   assert (trns_->proc == repeating_data_trns_proc);
2057   t->write_case = write_case;
2058   t->wc_data = wc_data;
2059 }