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

   1 /* PSPP - computes sample statistics.
   2    Copyright (C) 1997-9, 2000, 2006 Free Software Foundation, Inc.
   3    Written by Ben Pfaff <blp@gnu.org>.
   4
   5    This program is free software; you can redistribute it and/or
   6    modify it under the terms of the GNU General Public License as
   7    published by the Free Software Foundation; either version 2 of the
   8    License, or (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful, but
  11    WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13    General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18    02110-1301, USA. */
  19
  20 #include <config.h>
  21 #include <language/data-io/data-list.h>
  22 #include <libpspp/message.h>
  23 #include <ctype.h>
  24 #include <float.h>
  25 #include <stdio.h>
  26 #include <stdlib.h>
  27 #include <libpspp/alloc.h>
  28 #include <data/case.h>
  29 #include <language/command.h>
  30 #include <libpspp/compiler.h>
  31 #include <data/data-in.h>
  32 #include <libpspp/debug-print.h>
  33 #include <language/data-io/data-reader.h>
  34 #include <data/dictionary.h>
  35 #include <libpspp/message.h>
  36 #include <language/data-io/file-handle.h>
  37 #include <data/format.h>
  38 #include <language/lexer/lexer.h>
  39 #include <libpspp/misc.h>
  40 #include <data/settings.h>
  41 #include <libpspp/str.h>
  42 #include <output/table.h>
  43 #include <data/variable.h>
  44 #include <procedure.h>
  45
  46 #include "data-list.h"
  47
  48 #include "gettext.h"
  49 #define _(msgid) gettext (msgid)
  50 \f
  51 /* Utility function. */
  52
  53 /* FIXME: Either REPEATING DATA must be the last transformation, or we
  54    must multiplex the transformations that follow (i.e., perform them
  55    for every case that we produce from a repetition instance).
  56    Currently we do neither.  We should do one or the other. */
  57
  58 /* Describes how to parse one variable. */
  59 struct dls_var_spec
  60   {
  61     struct dls_var_spec *next;  /* Next specification in list. */
  62
  63     /* Both free and fixed formats. */
  64     struct fmt_spec input;      /* Input format of this field. */
  65     struct variable *v;         /* Associated variable.  Used only in
  66                                    parsing.  Not safe later. */
  67     int fv;                     /* First value in case. */
  68
  69     /* Fixed format only. */
  70     int rec;                    /* Record number (1-based). */
  71     int fc, lc;                 /* Column numbers in record. */
  72
  73     /* Free format only. */
  74     char name[LONG_NAME_LEN + 1]; /* Name of variable. */
  75   };
  76
  77 /* Constants for DATA LIST type. */
  78 /* Must match table in cmd_data_list(). */
  79 enum
  80   {
  81     DLS_FIXED,
  82     DLS_FREE,
  83     DLS_LIST
  84   };
  85
  86 /* DATA LIST private data structure. */
  87 struct data_list_pgm
  88   {
  89     struct dls_var_spec *first, *last;  /* Variable parsing specifications. */
  90     struct dfm_reader *reader;  /* Data file reader. */
  91
  92     int type;                   /* A DLS_* constant. */
  93     struct variable *end;       /* Variable specified on END subcommand. */
  94     int rec_cnt;                /* Number of records. */
  95     size_t case_size;           /* Case size in bytes. */
  96     char *delims;               /* Delimiters if any; not null-terminated. */
  97     size_t delim_cnt;           /* Number of delimiter, or 0 for spaces. */
  98   };
  99
 100 static const struct case_source_class data_list_source_class;
 101
 102 static int parse_fixed (struct data_list_pgm *);
 103 static int parse_free (struct dls_var_spec **, struct dls_var_spec **);
 104 static void dump_fixed_table (const struct dls_var_spec *,
 105                               const struct file_handle *, int rec_cnt);
 106 static void dump_free_table (const struct data_list_pgm *,
 107                              const struct file_handle *);
 108 static void destroy_dls_var_spec (struct dls_var_spec *);
 109 static trns_free_func data_list_trns_free;
 110 static trns_proc_func data_list_trns_proc;
 111
 112 /* Message title for REPEATING DATA. */
 113 #define RPD_ERR "REPEATING DATA: "
 114
 115 int
 116 cmd_data_list (void)
 117 {
 118   struct data_list_pgm *dls;
 119   int table = -1;                /* Print table if nonzero, -1=undecided. */
 120   struct file_handle *fh = fh_inline_file ();
 121
 122   if (!case_source_is_complex (vfm_source))
 123     discard_variables ();
 124
 125   dls = xmalloc (sizeof *dls);
 126   dls->reader = NULL;
 127   dls->type = -1;
 128   dls->end = NULL;
 129   dls->rec_cnt = 0;
 130   dls->delims = NULL;
 131   dls->delim_cnt = 0;
 132   dls->first = dls->last = NULL;
 133
 134   while (token != '/')
 135     {
 136       if (lex_match_id ("FILE"))
 137         {
 138           lex_match ('=');
 139           fh = fh_parse (FH_REF_FILE | FH_REF_INLINE);
 140           if (fh == NULL)
 141             goto error;
 142           if (case_source_is_class (vfm_source, &file_type_source_class)
 143               && fh != fh_get_default_handle ())
 144             {
 145               msg (SE, _("DATA LIST must use the same file "
 146                          "as the enclosing FILE TYPE."));
 147               goto error;
 148             }
 149         }
 150       else if (lex_match_id ("RECORDS"))
 151         {
 152           lex_match ('=');
 153           lex_match ('(');
 154           if (!lex_force_int ())
 155             goto error;
 156           dls->rec_cnt = lex_integer ();
 157           lex_get ();
 158           lex_match (')');
 159         }
 160       else if (lex_match_id ("END"))
 161         {
 162           if (dls->end)
 163             {
 164               msg (SE, _("The END subcommand may only be specified once."));
 165               goto error;
 166             }
 167
 168           lex_match ('=');
 169           if (!lex_force_id ())
 170             goto error;
 171           dls->end = dict_lookup_var (default_dict, tokid);
 172           if (!dls->end)
 173             dls->end = dict_create_var_assert (default_dict, tokid, 0);
 174           lex_get ();
 175         }
 176       else if (token == T_ID)
 177         {
 178           if (lex_match_id ("NOTABLE"))
 179             table = 0;
 180           else if (lex_match_id ("TABLE"))
 181             table = 1;
 182           else
 183             {
 184               int type;
 185               if (lex_match_id ("FIXED"))
 186                 type = DLS_FIXED;
 187               else if (lex_match_id ("FREE"))
 188                 type = DLS_FREE;
 189               else if (lex_match_id ("LIST"))
 190                 type = DLS_LIST;
 191               else
 192                 {
 193                   lex_error (NULL);
 194                   goto error;
 195                 }
 196
 197               if (dls->type != -1)
 198                 {
 199                   msg (SE, _("Only one of FIXED, FREE, or LIST may "
 200                              "be specified."));
 201                   goto error;
 202                 }
 203               dls->type = type;
 204
 205               if ((dls->type == DLS_FREE || dls->type == DLS_LIST)
 206                   && lex_match ('('))
 207                 {
 208                   while (!lex_match (')'))
 209                     {
 210                       int delim;
 211
 212                       if (lex_match_id ("TAB"))
 213                         delim = '\t';
 214                       else if (token == T_STRING && tokstr.length == 1)
 215                         {
 216                           delim = tokstr.string[0];
 217                           lex_get();
 218                         }
 219                       else
 220                         {
 221                           lex_error (NULL);
 222                           goto error;
 223                         }
 224
 225                       dls->delims = xrealloc (dls->delims, dls->delim_cnt + 1);
 226                       dls->delims[dls->delim_cnt++] = delim;
 227
 228                       lex_match (',');
 229                     }
 230                 }
 231             }
 232         }
 233       else
 234         {
 235           lex_error (NULL);
 236           goto error;
 237         }
 238     }
 239
 240   dls->case_size = dict_get_case_size (default_dict);
 241   fh_set_default_handle (fh);
 242
 243   if (dls->type == -1)
 244     dls->type = DLS_FIXED;
 245
 246   if (table == -1)
 247     {
 248       if (dls->type == DLS_FREE)
 249         table = 0;
 250       else
 251         table = 1;
 252     }
 253
 254   if (dls->type == DLS_FIXED)
 255     {
 256       if (!parse_fixed (dls))
 257         goto error;
 258       if (table)
 259         dump_fixed_table (dls->first, fh, dls->rec_cnt);
 260     }
 261   else
 262     {
 263       if (!parse_free (&dls->first, &dls->last))
 264         goto error;
 265       if (table)
 266         dump_free_table (dls, fh);
 267     }
 268
 269   dls->reader = dfm_open_reader (fh);
 270   if (dls->reader == NULL)
 271     goto error;
 272
 273   if (vfm_source != NULL)
 274     add_transformation (data_list_trns_proc, data_list_trns_free, dls);
 275   else
 276     vfm_source = create_case_source (&data_list_source_class, dls);
 277
 278   return CMD_SUCCESS;
 279
 280  error:
 281   data_list_trns_free (dls);
 282   return CMD_CASCADING_FAILURE;
 283 }
 284
 285 /* Adds SPEC to the linked list with head at FIRST and tail at
 286    LAST. */
 287 static void
 288 append_var_spec (struct dls_var_spec **first, struct dls_var_spec **last,
 289                  struct dls_var_spec *spec)
 290 {
 291   spec->next = NULL;
 292
 293   if (*first == NULL)
 294     *first = spec;
 295   else
 296     (*last)->next = spec;
 297   *last = spec;
 298 }
 299 \f
 300 /* Fixed-format parsing. */
 301
 302 /* Used for chaining together fortran-like format specifiers. */
 303 struct fmt_list
 304   {
 305     struct fmt_list *next;
 306     int count;
 307     struct fmt_spec f;
 308     struct fmt_list *down;
 309   };
 310
 311 /* State of parsing DATA LIST. */
 312 struct fixed_parsing_state
 313   {
 314     char **name;                /* Variable names. */
 315     size_t name_cnt;            /* Number of names. */
 316
 317     int recno;                  /* Index of current record. */
 318     int sc;                     /* 1-based column number of starting column for
 319                                    next field to output. */
 320   };
 321
 322 static int fixed_parse_compatible (struct fixed_parsing_state *,
 323                                    struct dls_var_spec **,
 324                                    struct dls_var_spec **);
 325 static int fixed_parse_fortran (struct fixed_parsing_state *,
 326                                 struct dls_var_spec **,
 327                                 struct dls_var_spec **);
 328
 329 /* Parses all the variable specifications for DATA LIST FIXED,
 330    storing them into DLS.  Returns nonzero if successful. */
 331 static int
 332 parse_fixed (struct data_list_pgm *dls)
 333 {
 334   struct fixed_parsing_state fx;
 335   size_t i;
 336
 337   fx.recno = 0;
 338   fx.sc = 1;
 339
 340   while (token != '.')
 341     {
 342       while (lex_match ('/'))
 343         {
 344           fx.recno++;
 345           if (lex_is_integer ())
 346             {
 347               if (lex_integer () < fx.recno)
 348                 {
 349                   msg (SE, _("The record number specified, %ld, is "
 350                              "before the previous record, %d.  Data "
 351                              "fields must be listed in order of "
 352                              "increasing record number."),
 353                        lex_integer (), fx.recno - 1);
 354                   return 0;
 355                 }
 356
 357               fx.recno = lex_integer ();
 358               lex_get ();
 359             }
 360           fx.sc = 1;
 361         }
 362
 363       if (!parse_DATA_LIST_vars (&fx.name, &fx.name_cnt, PV_NONE))
 364         return 0;
 365
 366       if (lex_is_number ())
 367         {
 368           if (!fixed_parse_compatible (&fx, &dls->first, &dls->last))
 369             goto fail;
 370         }
 371       else if (token == '(')
 372         {
 373           if (!fixed_parse_fortran (&fx, &dls->first, &dls->last))
 374             goto fail;
 375         }
 376       else
 377         {
 378           msg (SE, _("SPSS-like or FORTRAN-like format "
 379                      "specification expected after variable names."));
 380           goto fail;
 381         }
 382
 383       for (i = 0; i < fx.name_cnt; i++)
 384         free (fx.name[i]);
 385       free (fx.name);
 386     }
 387   if (dls->first == NULL)
 388     {
 389       msg (SE, _("At least one variable must be specified."));
 390       return 0;
 391     }
 392   if (dls->rec_cnt && dls->last->rec > dls->rec_cnt)
 393     {
 394       msg (SE, _("Variables are specified on records that "
 395                  "should not exist according to RECORDS subcommand."));
 396       return 0;
 397     }
 398   else if (!dls->rec_cnt)
 399     dls->rec_cnt = dls->last->rec;
 400   return lex_end_of_command () == CMD_SUCCESS;
 401
 402 fail:
 403   for (i = 0; i < fx.name_cnt; i++)
 404     free (fx.name[i]);
 405   free (fx.name);
 406   return 0;
 407 }
 408
 409 /* Parses a variable specification in the form 1-10 (A) based on
 410    FX and adds specifications to the linked list with head at
 411    FIRST and tail at LAST. */
 412 static int
 413 fixed_parse_compatible (struct fixed_parsing_state *fx,
 414                         struct dls_var_spec **first, struct dls_var_spec **last)
 415 {
 416   struct fmt_spec input;
 417   int fc, lc;
 418   int width;
 419   int i;
 420
 421   /* First column. */
 422   if (!lex_force_int ())
 423     return 0;
 424   fc = lex_integer ();
 425   if (fc < 1)
 426     {
 427       msg (SE, _("Column positions for fields must be positive."));
 428       return 0;
 429     }
 430   lex_get ();
 431
 432   /* Last column. */
 433   lex_negative_to_dash ();
 434   if (lex_match ('-'))
 435     {
 436       if (!lex_force_int ())
 437         return 0;
 438       lc = lex_integer ();
 439       if (lc < 1)
 440         {
 441           msg (SE, _("Column positions for fields must be positive."));
 442           return 0;
 443         }
 444       else if (lc < fc)
 445         {
 446           msg (SE, _("The ending column for a field must be "
 447                      "greater than the starting column."));
 448           return 0;
 449         }
 450
 451       lex_get ();
 452     }
 453   else
 454     lc = fc;
 455
 456   /* Divide columns evenly. */
 457   input.w = (lc - fc + 1) / fx->name_cnt;
 458   if ((lc - fc + 1) % fx->name_cnt)
 459     {
 460       msg (SE, _("The %d columns %d-%d "
 461                  "can't be evenly divided into %d fields."),
 462            lc - fc + 1, fc, lc, fx->name_cnt);
 463       return 0;
 464     }
 465
 466   /* Format specifier. */
 467   if (lex_match ('('))
 468     {
 469       struct fmt_desc *fdp;
 470
 471       if (token == T_ID)
 472         {
 473           const char *cp;
 474
 475           input.type = parse_format_specifier_name (&cp, 0);
 476           if (input.type == -1)
 477             return 0;
 478           if (*cp)
 479             {
 480               msg (SE, _("A format specifier on this line "
 481                          "has extra characters on the end."));
 482               return 0;
 483             }
 484
 485           lex_get ();
 486           lex_match (',');
 487         }
 488       else
 489         input.type = FMT_F;
 490
 491       if (lex_is_integer ())
 492         {
 493           if (lex_integer () < 1)
 494             {
 495               msg (SE, _("The value for number of decimal places "
 496                          "must be at least 1."));
 497               return 0;
 498             }
 499
 500           input.d = lex_integer ();
 501           lex_get ();
 502         }
 503       else
 504         input.d = 0;
 505
 506       fdp = &formats[input.type];
 507       if (fdp->n_args < 2 && input.d)
 508         {
 509           msg (SE, _("Input format %s doesn't accept decimal places."),
 510                fdp->name);
 511           return 0;
 512         }
 513
 514       if (input.d > 16)
 515         input.d = 16;
 516
 517       if (!lex_force_match (')'))
 518         return 0;
 519     }
 520   else
 521     {
 522       input.type = FMT_F;
 523       input.d = 0;
 524     }
 525   if (!check_input_specifier (&input, 1))
 526     return 0;
 527
 528   /* Start column for next specification. */
 529   fx->sc = lc + 1;
 530
 531   /* Width of variables to create. */
 532   if (input.type == FMT_A || input.type == FMT_AHEX)
 533     width = input.w;
 534   else
 535     width = 0;
 536
 537   /* Create variables and var specs. */
 538   for (i = 0; i < fx->name_cnt; i++)
 539     {
 540       struct dls_var_spec *spec;
 541       struct variable *v;
 542
 543       v = dict_create_var (default_dict, fx->name[i], width);
 544       if (v != NULL)
 545         {
 546           convert_fmt_ItoO (&input, &v->print);
 547           v->write = v->print;
 548           if (!case_source_is_complex (vfm_source))
 549             v->init = 0;
 550         }
 551       else
 552         {
 553           v = dict_lookup_var_assert (default_dict, fx->name[i]);
 554           if (vfm_source == NULL)
 555             {
 556               msg (SE, _("%s is a duplicate variable name."), fx->name[i]);
 557               return 0;
 558             }
 559           if ((width != 0) != (v->width != 0))
 560             {
 561               msg (SE, _("There is already a variable %s of a "
 562                          "different type."),
 563                    fx->name[i]);
 564               return 0;
 565             }
 566           if (width != 0 && width != v->width)
 567             {
 568               msg (SE, _("There is already a string variable %s of a "
 569                          "different width."), fx->name[i]);
 570               return 0;
 571             }
 572         }
 573
 574       spec = xmalloc (sizeof *spec);
 575       spec->input = input;
 576       spec->v = v;
 577       spec->fv = v->fv;
 578       spec->rec = fx->recno;
 579       spec->fc = fc + input.w * i;
 580       spec->lc = spec->fc + input.w - 1;
 581       append_var_spec (first, last, spec);
 582     }
 583   return 1;
 584 }
 585
 586 /* Destroy format list F and, if RECURSE is nonzero, all its
 587    sublists. */
 588 static void
 589 destroy_fmt_list (struct fmt_list *f, int recurse)
 590 {
 591   struct fmt_list *next;
 592
 593   for (; f; f = next)
 594     {
 595       next = f->next;
 596       if (recurse && f->f.type == FMT_DESCEND)
 597         destroy_fmt_list (f->down, 1);
 598       free (f);
 599     }
 600 }
 601
 602 /* Takes a hierarchically structured fmt_list F as constructed by
 603    fixed_parse_fortran(), and flattens it, adding the variable
 604    specifications to the linked list with head FIRST and tail
 605    LAST.  NAME_IDX is used to take values from the list of names
 606    in FX; it should initially point to a value of 0. */
 607 static int
 608 dump_fmt_list (struct fixed_parsing_state *fx, struct fmt_list *f,
 609                struct dls_var_spec **first, struct dls_var_spec **last,
 610                int *name_idx)
 611 {
 612   int i;
 613
 614   for (; f; f = f->next)
 615     if (f->f.type == FMT_X)
 616       fx->sc += f->count;
 617     else if (f->f.type == FMT_T)
 618       fx->sc = f->f.w;
 619     else if (f->f.type == FMT_NEWREC)
 620       {
 621         fx->recno += f->count;
 622         fx->sc = 1;
 623       }
 624     else
 625       for (i = 0; i < f->count; i++)
 626         if (f->f.type == FMT_DESCEND)
 627           {
 628             if (!dump_fmt_list (fx, f->down, first, last, name_idx))
 629               return 0;
 630           }
 631         else
 632           {
 633             struct dls_var_spec *spec;
 634             int width;
 635             struct variable *v;
 636
 637             if (formats[f->f.type].cat & FCAT_STRING)
 638               width = f->f.w;
 639             else
 640               width = 0;
 641             if (*name_idx >= fx->name_cnt)
 642               {
 643                 msg (SE, _("The number of format "
 644                            "specifications exceeds the given number of "
 645                            "variable names."));
 646                 return 0;
 647               }
 648
 649             v = dict_create_var (default_dict, fx->name[(*name_idx)++], width);
 650             if (!v)
 651               {
 652                 msg (SE, _("%s is a duplicate variable name."), fx->name[i]);
 653                 return 0;
 654               }
 655
 656             if (!case_source_is_complex (vfm_source))
 657               v->init = 0;
 658
 659             spec = xmalloc (sizeof *spec);
 660             spec->v = v;
 661             spec->input = f->f;
 662             spec->fv = v->fv;
 663             spec->rec = fx->recno;
 664             spec->fc = fx->sc;
 665             spec->lc = fx->sc + f->f.w - 1;
 666             append_var_spec (first, last, spec);
 667
 668             convert_fmt_ItoO (&spec->input, &v->print);
 669             v->write = v->print;
 670
 671             fx->sc += f->f.w;
 672           }
 673   return 1;
 674 }
 675
 676 /* Recursively parses a FORTRAN-like format specification into
 677    the linked list with head FIRST and tail TAIL.  LEVEL is the
 678    level of recursion, starting from 0.  Returns the parsed
 679    specification if successful, or a null pointer on failure.  */
 680 static struct fmt_list *
 681 fixed_parse_fortran_internal (struct fixed_parsing_state *fx,
 682                               struct dls_var_spec **first,
 683                               struct dls_var_spec **last)
 684 {
 685   struct fmt_list *head = NULL;
 686   struct fmt_list *tail = NULL;
 687
 688   lex_force_match ('(');
 689   while (token != ')')
 690     {
 691       /* New fmt_list. */
 692       struct fmt_list *new = xmalloc (sizeof *new);
 693       new->next = NULL;
 694
 695       /* Append new to list. */
 696       if (head != NULL)
 697         tail->next = new;
 698       else
 699         head = new;
 700       tail = new;
 701
 702       /* Parse count. */
 703       if (lex_is_integer ())
 704         {
 705           new->count = lex_integer ();
 706           lex_get ();
 707         }
 708       else
 709         new->count = 1;
 710
 711       /* Parse format specifier. */
 712       if (token == '(')
 713         {
 714           new->f.type = FMT_DESCEND;
 715           new->down = fixed_parse_fortran_internal (fx, first, last);
 716           if (new->down == NULL)
 717             goto fail;
 718         }
 719       else if (lex_match ('/'))
 720         new->f.type = FMT_NEWREC;
 721       else if (!parse_format_specifier (&new->f, FMTP_ALLOW_XT)
 722                || !check_input_specifier (&new->f, 1))
 723         goto fail;
 724
 725       lex_match (',');
 726     }
 727   lex_force_match (')');
 728
 729   return head;
 730
 731 fail:
 732   destroy_fmt_list (head, 0);
 733
 734   return NULL;
 735 }
 736
 737 /* Parses a FORTRAN-like format specification into the linked
 738    list with head FIRST and tail LAST.  Returns nonzero if
 739    successful. */
 740 static int
 741 fixed_parse_fortran (struct fixed_parsing_state *fx,
 742                      struct dls_var_spec **first, struct dls_var_spec **last)
 743 {
 744   struct fmt_list *list;
 745   int name_idx;
 746
 747   list = fixed_parse_fortran_internal (fx, first, last);
 748   if (list == NULL)
 749     return 0;
 750
 751   name_idx = 0;
 752   dump_fmt_list (fx, list, first, last, &name_idx);
 753   destroy_fmt_list (list, 1);
 754   if (name_idx < fx->name_cnt)
 755     {
 756       msg (SE, _("There aren't enough format specifications "
 757                  "to match the number of variable names given."));
 758       return 0;
 759     }
 760
 761   return 1;
 762 }
 763
 764 /* Displays a table giving information on fixed-format variable
 765    parsing on DATA LIST. */
 766 /* FIXME: The `Columns' column should be divided into three columns,
 767    one for the starting column, one for the dash, one for the ending
 768    column; then right-justify the starting column and left-justify the
 769    ending column. */
 770 static void
 771 dump_fixed_table (const struct dls_var_spec *specs,
 772                   const struct file_handle *fh, int rec_cnt)
 773 {
 774   const struct dls_var_spec *spec;
 775   struct tab_table *t;
 776   int i;
 777
 778   for (i = 0, spec = specs; spec; spec = spec->next)
 779     i++;
 780   t = tab_create (4, i + 1, 0);
 781   tab_columns (t, TAB_COL_DOWN, 1);
 782   tab_headers (t, 0, 0, 1, 0);
 783   tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable"));
 784   tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Record"));
 785   tab_text (t, 2, 0, TAB_CENTER | TAT_TITLE, _("Columns"));
 786   tab_text (t, 3, 0, TAB_CENTER | TAT_TITLE, _("Format"));
 787   tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 3, i);
 788   tab_hline (t, TAL_2, 0, 3, 1);
 789   tab_dim (t, tab_natural_dimensions);
 790
 791   for (i = 1, spec = specs; spec; spec = spec->next, i++)
 792     {
 793       tab_text (t, 0, i, TAB_LEFT, spec->v->name);
 794       tab_text (t, 1, i, TAT_PRINTF, "%d", spec->rec);
 795       tab_text (t, 2, i, TAT_PRINTF, "%3d-%3d",
 796                     spec->fc, spec->lc);
 797       tab_text (t, 3, i, TAB_LEFT | TAB_FIX,
 798                     fmt_to_string (&spec->input));
 799     }
 800
 801   tab_title (t, ngettext ("Reading %d record from %s.",
 802                           "Reading %d records from %s.", rec_cnt),
 803              rec_cnt, fh_get_name (fh));
 804   tab_submit (t);
 805 }
 806 \f
 807 /* Free-format parsing. */
 808
 809 /* Parses variable specifications for DATA LIST FREE and adds
 810    them to the linked list with head FIRST and tail LAST.
 811    Returns nonzero only if successful. */
 812 static int
 813 parse_free (struct dls_var_spec **first, struct dls_var_spec **last)
 814 {
 815   lex_get ();
 816   while (token != '.')
 817     {
 818       struct fmt_spec input, output;
 819       char **name;
 820       size_t name_cnt;
 821       int width;
 822       size_t i;
 823
 824       if (!parse_DATA_LIST_vars (&name, &name_cnt, PV_NONE))
 825         return 0;
 826
 827       if (lex_match ('('))
 828         {
 829           if (!parse_format_specifier (&input, 0)
 830               || !check_input_specifier (&input, 1)
 831               || !lex_force_match (')'))
 832             {
 833               for (i = 0; i < name_cnt; i++)
 834                 free (name[i]);
 835               free (name);
 836               return 0;
 837             }
 838           convert_fmt_ItoO (&input, &output);
 839         }
 840       else
 841         {
 842           lex_match ('*');
 843           input = make_input_format (FMT_F, 8, 0);
 844           output = *get_format ();
 845         }
 846
 847       if (input.type == FMT_A || input.type == FMT_AHEX)
 848         width = input.w;
 849       else
 850         width = 0;
 851       for (i = 0; i < name_cnt; i++)
 852         {
 853           struct dls_var_spec *spec;
 854           struct variable *v;
 855
 856           v = dict_create_var (default_dict, name[i], width);
 857
 858           if (!v)
 859             {
 860               msg (SE, _("%s is a duplicate variable name."), name[i]);
 861               return 0;
 862             }
 863           v->print = v->write = output;
 864
 865           if (!case_source_is_complex (vfm_source))
 866             v->init = 0;
 867
 868           spec = xmalloc (sizeof *spec);
 869           spec->input = input;
 870           spec->v = v;
 871           spec->fv = v->fv;
 872           str_copy_trunc (spec->name, sizeof spec->name, v->name);
 873           append_var_spec (first, last, spec);
 874         }
 875       for (i = 0; i < name_cnt; i++)
 876         free (name[i]);
 877       free (name);
 878     }
 879
 880   return lex_end_of_command () == CMD_SUCCESS;
 881 }
 882
 883 /* Displays a table giving information on free-format variable parsing
 884    on DATA LIST. */
 885 static void
 886 dump_free_table (const struct data_list_pgm *dls,
 887                  const struct file_handle *fh)
 888 {
 889   struct tab_table *t;
 890   int i;
 891
 892   {
 893     struct dls_var_spec *spec;
 894     for (i = 0, spec = dls->first; spec; spec = spec->next)
 895       i++;
 896   }
 897
 898   t = tab_create (2, i + 1, 0);
 899   tab_columns (t, TAB_COL_DOWN, 1);
 900   tab_headers (t, 0, 0, 1, 0);
 901   tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable"));
 902   tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Format"));
 903   tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 1, i);
 904   tab_hline (t, TAL_2, 0, 1, 1);
 905   tab_dim (t, tab_natural_dimensions);
 906
 907   {
 908     struct dls_var_spec *spec;
 909
 910     for (i = 1, spec = dls->first; spec; spec = spec->next, i++)
 911       {
 912         tab_text (t, 0, i, TAB_LEFT, spec->v->name);
 913         tab_text (t, 1, i, TAB_LEFT | TAB_FIX, fmt_to_string (&spec->input));
 914       }
 915   }
 916
 917   tab_title (t, _("Reading free-form data from %s."), fh_get_name (fh));
 918
 919   tab_submit (t);
 920 }
 921 \f
 922 /* Input procedure. */
 923
 924 /* Extracts a field from the current position in the current
 925    record.  Fields can be unquoted or quoted with single- or
 926    double-quote characters.  *FIELD is set to the field content.
 927    After parsing the field, sets the current position in the
 928    record to just past the field and any trailing delimiter.
 929    END_BLANK is used internally; it should be initialized by the
 930    caller to 0 and left alone afterward.  Returns 0 on failure or
 931    a 1-based column number indicating the beginning of the field
 932    on success. */
 933 static int
 934 cut_field (const struct data_list_pgm *dls, struct fixed_string *field,
 935            int *end_blank)
 936 {
 937   struct fixed_string line;
 938   char *cp;
 939   size_t column_start;
 940
 941   if (dfm_eof (dls->reader))
 942     return 0;
 943   if (dls->delim_cnt == 0)
 944     dfm_expand_tabs (dls->reader);
 945   dfm_get_record (dls->reader, &line);
 946
 947   cp = ls_c_str (&line);
 948   if (dls->delim_cnt == 0)
 949     {
 950       /* Skip leading whitespace. */
 951       while (cp < ls_end (&line) && isspace ((unsigned char) *cp))
 952         cp++;
 953       if (cp >= ls_end (&line))
 954         return 0;
 955
 956       /* Handle actual data, whether quoted or unquoted. */
 957       if (*cp == '\'' || *cp == '"')
 958         {
 959           int quote = *cp;
 960
 961           field->string = ++cp;
 962           while (cp < ls_end (&line) && *cp != quote)
 963             cp++;
 964           field->length = cp - field->string;
 965           if (cp < ls_end (&line))
 966             cp++;
 967           else
 968             msg (SW, _("Quoted string missing terminating `%c'."), quote);
 969         }
 970       else
 971         {
 972           field->string = cp;
 973           while (cp < ls_end (&line)
 974                  && !isspace ((unsigned char) *cp) && *cp != ',')
 975             cp++;
 976           field->length = cp - field->string;
 977         }
 978
 979       /* Skip trailing whitespace and a single comma if present. */
 980       while (cp < ls_end (&line) && isspace ((unsigned char) *cp))
 981         cp++;
 982       if (cp < ls_end (&line) && *cp == ',')
 983         cp++;
 984     }
 985   else
 986     {
 987       if (cp >= ls_end (&line))
 988         {
 989           int column = dfm_column_start (dls->reader);
 990                /* A blank line or a line that ends in \t has a
 991              trailing blank field. */
 992           if (column == 1 || (column > 1 && cp[-1] == '\t'))
 993             {
 994               if (*end_blank == 0)
 995                 {
 996                   *end_blank = 1;
 997                   field->string = ls_end (&line);
 998                   field->length = 0;
 999                   dfm_forward_record (dls->reader);
1000                   return column;
1001                 }
1002               else
1003                 {
1004                   *end_blank = 0;
1005                   return 0;
1006                 }
1007             }
1008           else
1009             return 0;
1010         }
1011       else
1012         {
1013           field->string = cp;
1014           while (cp < ls_end (&line)
1015                  && memchr (dls->delims, *cp, dls->delim_cnt) == NULL)
1016             cp++;
1017           field->length = cp - field->string;
1018           if (cp < ls_end (&line))
1019             cp++;
1020         }
1021     }
1022
1023   dfm_forward_columns (dls->reader, field->string - line.string);
1024   column_start = dfm_column_start (dls->reader);
1025
1026   dfm_forward_columns (dls->reader, cp - field->string);
1027
1028   return column_start;
1029 }
1030
1031 static bool read_from_data_list_fixed (const struct data_list_pgm *,
1032                                        struct ccase *);
1033 static bool read_from_data_list_free (const struct data_list_pgm *,
1034                                       struct ccase *);
1035 static bool read_from_data_list_list (const struct data_list_pgm *,
1036                                       struct ccase *);
1037
1038 /* Reads a case from DLS into C.
1039    Returns true if successful, false at end of file or on I/O error. */
1040 static bool
1041 read_from_data_list (const struct data_list_pgm *dls, struct ccase *c)
1042 {
1043   bool retval;
1044
1045   dfm_push (dls->reader);
1046   switch (dls->type)
1047     {
1048     case DLS_FIXED:
1049       retval = read_from_data_list_fixed (dls, c);
1050       break;
1051     case DLS_FREE:
1052       retval = read_from_data_list_free (dls, c);
1053       break;
1054     case DLS_LIST:
1055       retval = read_from_data_list_list (dls, c);
1056       break;
1057     default:
1058       abort ();
1059     }
1060   dfm_pop (dls->reader);
1061
1062   return retval;
1063 }
1064
1065 /* Reads a case from the data file into C, parsing it according
1066    to fixed-format syntax rules in DLS.
1067    Returns true if successful, false at end of file or on I/O error. */
1068 static bool
1069 read_from_data_list_fixed (const struct data_list_pgm *dls, struct ccase *c)
1070 {
1071   struct dls_var_spec *var_spec = dls->first;
1072   int i;
1073
1074   if (dfm_eof (dls->reader))
1075     return false;
1076   for (i = 1; i <= dls->rec_cnt; i++)
1077     {
1078       struct fixed_string line;
1079
1080       if (dfm_eof (dls->reader))
1081         {
1082           /* Note that this can't occur on the first record. */
1083           msg (SW, _("Partial case of %d of %d records discarded."),
1084                i - 1, dls->rec_cnt);
1085           return false;
1086         }
1087       dfm_expand_tabs (dls->reader);
1088       dfm_get_record (dls->reader, &line);
1089
1090       for (; var_spec && i == var_spec->rec; var_spec = var_spec->next)
1091         {
1092           struct data_in di;
1093
1094           data_in_finite_line (&di, ls_c_str (&line), ls_length (&line),
1095                                var_spec->fc, var_spec->lc);
1096           di.v = case_data_rw (c, var_spec->fv);
1097           di.flags = DI_IMPLIED_DECIMALS;
1098           di.f1 = var_spec->fc;
1099           di.format = var_spec->input;
1100
1101           data_in (&di);
1102         }
1103
1104       dfm_forward_record (dls->reader);
1105     }
1106
1107   return true;
1108 }
1109
1110 /* Reads a case from the data file into C, parsing it according
1111    to free-format syntax rules in DLS.
1112    Returns true if successful, false at end of file or on I/O error. */
1113 static bool
1114 read_from_data_list_free (const struct data_list_pgm *dls, struct ccase *c)
1115 {
1116   struct dls_var_spec *var_spec;
1117   int end_blank = 0;
1118
1119   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1120     {
1121       struct fixed_string field;
1122       int column;
1123
1124       /* Cut out a field and read in a new record if necessary. */
1125       for (;;)
1126         {
1127           column = cut_field (dls, &field, &end_blank);
1128           if (column != 0)
1129             break;
1130
1131           if (!dfm_eof (dls->reader))
1132             dfm_forward_record (dls->reader);
1133           if (dfm_eof (dls->reader))
1134             {
1135               if (var_spec != dls->first)
1136                 msg (SW, _("Partial case discarded.  The first variable "
1137                            "missing was %s."), var_spec->name);
1138               return false;
1139             }
1140         }
1141
1142       {
1143         struct data_in di;
1144
1145         di.s = ls_c_str (&field);
1146         di.e = ls_end (&field);
1147         di.v = case_data_rw (c, var_spec->fv);
1148         di.flags = 0;
1149         di.f1 = column;
1150         di.format = var_spec->input;
1151         data_in (&di);
1152       }
1153     }
1154   return true;
1155 }
1156
1157 /* Reads a case from the data file and parses it according to
1158    list-format syntax rules.
1159    Returns true if successful, false at end of file or on I/O error. */
1160 static bool
1161 read_from_data_list_list (const struct data_list_pgm *dls, struct ccase *c)
1162 {
1163   struct dls_var_spec *var_spec;
1164   int end_blank = 0;
1165
1166   if (dfm_eof (dls->reader))
1167     return false;
1168
1169   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1170     {
1171       struct fixed_string field;
1172       int column;
1173
1174       /* Cut out a field and check for end-of-line. */
1175       column = cut_field (dls, &field, &end_blank);
1176       if (column == 0)
1177         {
1178           if (get_undefined ())
1179             msg (SW, _("Missing value(s) for all variables from %s onward.  "
1180                        "These will be filled with the system-missing value "
1181                        "or blanks, as appropriate."),
1182                  var_spec->name);
1183           for (; var_spec; var_spec = var_spec->next)
1184             {
1185               int width = get_format_var_width (&var_spec->input);
1186               if (width == 0)
1187                 case_data_rw (c, var_spec->fv)->f = SYSMIS;
1188               else
1189                 memset (case_data_rw (c, var_spec->fv)->s, ' ', width);
1190             }
1191           break;
1192         }
1193
1194       {
1195         struct data_in di;
1196
1197         di.s = ls_c_str (&field);
1198         di.e = ls_end (&field);
1199         di.v = case_data_rw (c, var_spec->fv);
1200         di.flags = 0;
1201         di.f1 = column;
1202         di.format = var_spec->input;
1203         data_in (&di);
1204       }
1205     }
1206
1207   dfm_forward_record (dls->reader);
1208   return true;
1209 }
1210
1211 /* Destroys SPEC. */
1212 static void
1213 destroy_dls_var_spec (struct dls_var_spec *spec)
1214 {
1215   struct dls_var_spec *next;
1216
1217   while (spec != NULL)
1218     {
1219       next = spec->next;
1220       free (spec);
1221       spec = next;
1222     }
1223 }
1224
1225 /* Destroys DATA LIST transformation DLS.
1226    Returns true if successful, false if an I/O error occurred. */
1227 static bool
1228 data_list_trns_free (void *dls_)
1229 {
1230   struct data_list_pgm *dls = dls_;
1231   free (dls->delims);
1232   destroy_dls_var_spec (dls->first);
1233   dfm_close_reader (dls->reader);
1234   free (dls);
1235   return true;
1236 }
1237
1238 /* Handle DATA LIST transformation DLS, parsing data into C. */
1239 static int
1240 data_list_trns_proc (void *dls_, struct ccase *c, int case_num UNUSED)
1241 {
1242   struct data_list_pgm *dls = dls_;
1243   int retval;
1244
1245   if (read_from_data_list (dls, c))
1246     retval = TRNS_CONTINUE;
1247   else if (dfm_reader_error (dls->reader) || dfm_eof (dls->reader) > 1)
1248     {
1249       /* An I/O error, or encountering end of file for a second
1250          time, should be escalated into a more serious error. */
1251       retval = TRNS_ERROR;
1252     }
1253   else
1254     retval = TRNS_DROP_CASE;
1255
1256   /* If there was an END subcommand handle it. */
1257   if (dls->end != NULL)
1258     {
1259       double *end = &case_data_rw (c, dls->end->fv)->f;
1260       if (retval == TRNS_DROP_CASE)
1261         {
1262           *end = 1.0;
1263           retval = TRNS_CONTINUE;
1264         }
1265       else
1266         *end = 0.0;
1267     }
1268
1269   return retval;
1270 }
1271 \f
1272 /* Reads all the records from the data file and passes them to
1273    write_case().
1274    Returns true if successful, false if an I/O error occurred. */
1275 static bool
1276 data_list_source_read (struct case_source *source,
1277                        struct ccase *c,
1278                        write_case_func *write_case, write_case_data wc_data)
1279 {
1280   struct data_list_pgm *dls = source->aux;
1281
1282   for (;;)
1283     {
1284       bool ok;
1285
1286       if (!read_from_data_list (dls, c))
1287         return !dfm_reader_error (dls->reader);
1288
1289       dfm_push (dls->reader);
1290       ok = write_case (wc_data);
1291       dfm_pop (dls->reader);
1292       if (!ok)
1293         return false;
1294     }
1295 }
1296
1297 /* Destroys the source's internal data. */
1298 static void
1299 data_list_source_destroy (struct case_source *source)
1300 {
1301   data_list_trns_free (source->aux);
1302 }
1303
1304 static const struct case_source_class data_list_source_class =
1305   {
1306     "DATA LIST",
1307     NULL,
1308     data_list_source_read,
1309     data_list_source_destroy,
1310   };
1311 \f
1312 /* REPEATING DATA. */
1313
1314 /* Represents a number or a variable. */
1315 struct rpd_num_or_var
1316   {
1317     int num;                    /* Value, or 0. */
1318     struct variable *var;       /* Variable, if number==0. */
1319   };
1320
1321 /* REPEATING DATA private data structure. */
1322 struct repeating_data_trns
1323   {
1324     struct dls_var_spec *first, *last;  /* Variable parsing specifications. */
1325     struct dfm_reader *reader;          /* Input file, never NULL. */
1326
1327     struct rpd_num_or_var starts_beg;   /* STARTS=, before the dash. */
1328     struct rpd_num_or_var starts_end;   /* STARTS=, after the dash. */
1329     struct rpd_num_or_var occurs;       /* OCCURS= subcommand. */
1330     struct rpd_num_or_var length;       /* LENGTH= subcommand. */
1331     struct rpd_num_or_var cont_beg;     /* CONTINUED=, before the dash. */
1332     struct rpd_num_or_var cont_end;     /* CONTINUED=, after the dash. */
1333
1334     /* ID subcommand. */
1335     int id_beg, id_end;                 /* Beginning & end columns. */
1336     struct variable *id_var;            /* DATA LIST variable. */
1337     struct fmt_spec id_spec;            /* Input format spec. */
1338     union value *id_value;              /* ID value. */
1339
1340     write_case_func *write_case;
1341     write_case_data wc_data;
1342   };
1343
1344 static trns_free_func repeating_data_trns_free;
1345 static int parse_num_or_var (struct rpd_num_or_var *, const char *);
1346 static int parse_repeating_data (struct dls_var_spec **,
1347                                  struct dls_var_spec **);
1348 static void find_variable_input_spec (struct variable *v,
1349                                       struct fmt_spec *spec);
1350
1351 /* 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_CASCADING_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 TRNS_CONTINUE on success,
1881    TRNS_DROP_CASE on end of file or on failure, or TRNS_NEXT_CASE. */
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 TRNS_DROP_CASE;
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 TRNS_NEXT_CASE;
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 TRNS_NEXT_CASE;
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 TRNS_DROP_CASE;
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 TRNS_DROP_CASE;
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 TRNS_DROP_CASE;
1975       occurs_left -= code;
1976     }
1977   else if (cont_beg == 0)
1978     return TRNS_NEXT_CASE;
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 TRNS_DROP_CASE;
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 TRNS_DROP_CASE;
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 TRNS_DROP_CASE;
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 TRNS_NEXT_CASE;
2033 }
2034
2035 /* Frees a REPEATING DATA transformation.
2036    Returns true if successful, false if an I/O error occurred. */
2037 bool
2038 repeating_data_trns_free (void *rpd_)
2039 {
2040   struct repeating_data_trns *rpd = rpd_;
2041
2042   destroy_dls_var_spec (rpd->first);
2043   dfm_close_reader (rpd->reader);
2044   free (rpd->id_value);
2045   free (rpd);
2046   return true;
2047 }
2048
2049 /* Lets repeating_data_trns_proc() know how to write the cases
2050    that it composes.  Not elegant. */
2051 void
2052 repeating_data_set_write_case (struct transformation *trns_,
2053                                write_case_func *write_case,
2054                                write_case_data wc_data)
2055 {
2056   struct repeating_data_trns *t = trns_->private;
2057
2058   assert (trns_->proc == repeating_data_trns_proc);
2059   t->write_case = write_case;
2060   t->wc_data = wc_data;
2061 }