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