src/data-list.c

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