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