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