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 "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   if (!case_source_is_complex (vfm_source))
 115     discard_variables ();
 116
 117   dls = xmalloc (sizeof *dls);
 118   dls->handle = default_handle;
 119   dls->type = -1;
 120   dls->end = NULL;
 121   dls->eof = 0;
 122   dls->nrec = 0;
 123   dls->first = dls->last = NULL;
 124
 125   while (token != '/')
 126     {
 127       if (lex_match_id ("FILE"))
 128         {
 129           lex_match ('=');
 130           dls->handle = fh_parse_file_handle ();
 131           if (!dls->handle)
 132             goto error;
 133           if (case_source_is_class (vfm_source, &file_type_source_class)
 134               && dls->handle != default_handle)
 135             {
 136               msg (SE, _("DATA LIST may not use a different file from "
 137                          "that specified on its surrounding FILE TYPE."));
 138               goto error;
 139             }
 140         }
 141       else if (lex_match_id ("RECORDS"))
 142         {
 143           lex_match ('=');
 144           lex_match ('(');
 145           if (!lex_force_int ())
 146             goto error;
 147           dls->nrec = lex_integer ();
 148           lex_get ();
 149           lex_match (')');
 150         }
 151       else if (lex_match_id ("END"))
 152         {
 153           if (dls->end)
 154             {
 155               msg (SE, _("The END subcommand may only be specified once."));
 156               goto error;
 157             }
 158
 159           lex_match ('=');
 160           if (!lex_force_id ())
 161             goto error;
 162           dls->end = dict_lookup_var (default_dict, tokid);
 163           if (!dls->end)
 164             dls->end = dict_create_var_assert (default_dict, tokid, 0);
 165           lex_get ();
 166         }
 167       else if (token == T_ID)
 168         {
 169           /* Must match DLS_* constants. */
 170           static const char *id[] = {"FIXED", "FREE", "LIST", "NOTABLE",
 171                                      "TABLE", NULL};
 172           const char **p;
 173           int index;
 174
 175           for (p = id; *p; p++)
 176             if (lex_id_match (*p, tokid))
 177               break;
 178           if (*p == NULL)
 179             {
 180               lex_error (NULL);
 181               goto error;
 182             }
 183
 184           lex_get ();
 185
 186           index = p - id;
 187           if (index < 3)
 188             {
 189               if (dls->type != -1)
 190                 {
 191                   msg (SE, _("Only one of FIXED, FREE, or LIST may "
 192                             "be specified."));
 193                   goto error;
 194                 }
 195
 196               dls->type = index;
 197             }
 198           else
 199             table = index - 3;
 200         }
 201       else
 202         {
 203           lex_error (NULL);
 204           goto error;
 205         }
 206     }
 207
 208   dls->case_size = dict_get_case_size (default_dict);
 209   default_handle = dls->handle;
 210
 211   if (dls->type == -1)
 212     dls->type = DLS_FIXED;
 213
 214   if (table == -1)
 215     {
 216       if (dls->type == DLS_FREE)
 217         table = 0;
 218       else
 219         table = 1;
 220     }
 221
 222   if (dls->type == DLS_FIXED)
 223     {
 224       if (!parse_fixed (dls))
 225         goto error;
 226       if (table)
 227         dump_fixed_table (dls->first, dls->handle, dls->nrec);
 228     }
 229   else
 230     {
 231       if (!parse_free (&dls->first, &dls->last))
 232         goto error;
 233       if (table)
 234         dump_free_table (dls);
 235     }
 236
 237   if (!dfm_open_for_reading (dls->handle))
 238     goto error;
 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 = handle_get_filename (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   local_free (buf);
 801 }
 802 \f
 803 /* Free-format parsing. */
 804
 805 /* Parses variable specifications for DATA LIST FREE and adds
 806    them to the linked list with head FIRST and tail LAST.
 807    Returns nonzero only if successful. */
 808 static int
 809 parse_free (struct dls_var_spec **first, struct dls_var_spec **last)
 810 {
 811   lex_get ();
 812   while (token != '.')
 813     {
 814       struct fmt_spec input, output;
 815       char **name;
 816       int name_cnt;
 817       int width;
 818       int i;
 819
 820       if (!parse_DATA_LIST_vars (&name, &name_cnt, PV_NONE))
 821         return 0;
 822       if (lex_match ('('))
 823         {
 824           if (!parse_format_specifier (&input, 0)
 825               || !check_input_specifier (&input)
 826               || !lex_force_match (')'))
 827             {
 828               for (i = 0; i < name_cnt; i++)
 829                 free (name[i]);
 830               free (name);
 831               return 0;
 832             }
 833           convert_fmt_ItoO (&input, &output);
 834         }
 835       else
 836         {
 837           lex_match ('*');
 838           input.type = FMT_F;
 839           input.w = 8;
 840           input.d = 0;
 841           output = get_format();
 842         }
 843
 844       if (input.type == FMT_A || input.type == FMT_AHEX)
 845         width = input.w;
 846       else
 847         width = 0;
 848       for (i = 0; i < name_cnt; i++)
 849         {
 850           struct dls_var_spec *spec;
 851           struct variable *v;
 852
 853           v = dict_create_var (default_dict, name[i], width);
 854           if (!v)
 855             {
 856               msg (SE, _("%s is a duplicate variable name."), name[i]);
 857               return 0;
 858             }
 859           v->print = v->write = output;
 860
 861           if (!case_source_is_complex (vfm_source))
 862             v->init = 0;
 863
 864           spec = xmalloc (sizeof *spec);
 865           spec->input = input;
 866           spec->v = v;
 867           spec->fv = v->fv;
 868           strcpy (spec->name, name[i]);
 869           append_var_spec (first, last, spec);
 870         }
 871       for (i = 0; i < name_cnt; i++)
 872         free (name[i]);
 873       free (name);
 874     }
 875
 876   if (token != '.')
 877     lex_error (_("expecting end of command"));
 878   return 1;
 879 }
 880
 881 /* Displays a table giving information on free-format variable parsing
 882    on DATA LIST. */
 883 static void
 884 dump_free_table (const struct data_list_pgm *dls)
 885 {
 886   struct tab_table *t;
 887   int i;
 888
 889   {
 890     struct dls_var_spec *spec;
 891     for (i = 0, spec = dls->first; spec; spec = spec->next)
 892       i++;
 893   }
 894
 895   t = tab_create (2, i + 1, 0);
 896   tab_columns (t, TAB_COL_DOWN, 1);
 897   tab_headers (t, 0, 0, 1, 0);
 898   tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable"));
 899   tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Format"));
 900   tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 1, i);
 901   tab_hline (t, TAL_2, 0, 1, 1);
 902   tab_dim (t, tab_natural_dimensions);
 903
 904   {
 905     struct dls_var_spec *spec;
 906
 907     for (i = 1, spec = dls->first; spec; spec = spec->next, i++)
 908       {
 909         tab_text (t, 0, i, TAB_LEFT, spec->v->name);
 910         tab_text (t, 1, i, TAB_LEFT | TAT_FIX, fmt_to_string (&spec->input));
 911       }
 912   }
 913
 914   {
 915     const char *filename;
 916
 917     filename = handle_get_filename (dls->handle);
 918     if (filename == NULL)
 919       filename = "";
 920     tab_title (t, 1,
 921                (dls->handle != inline_file
 922                 ? _("Reading free-form data from file %s.")
 923                 : _("Reading free-form data from the command file.")),
 924                filename);
 925   }
 926
 927   tab_submit (t);
 928 }
 929 \f
 930 /* Input procedure. */
 931
 932 /* Extracts a field from the current position in the current record.
 933    Fields can be unquoted or quoted with single- or double-quote
 934    characters.  *RET_LEN is set to the field length, *RET_CP is set to
 935    the field itself.  After parsing the field, sets the current
 936    position in the record to just past the field.  Returns 0 on
 937    failure or a 1-based column number indicating the beginning of the
 938    field on success. */
 939 static int
 940 cut_field (const struct data_list_pgm *dls, char **ret_cp, int *ret_len)
 941 {
 942   char *cp, *ep;
 943   int len;
 944
 945   cp = dfm_get_record (dls->handle, &len);
 946   if (!cp)
 947     return 0;
 948
 949   ep = cp + len;
 950
 951   /* Skip leading whitespace and commas. */
 952   while ((isspace ((unsigned char) *cp) || *cp == ',') && cp < ep)
 953     cp++;
 954   if (cp >= ep)
 955     return 0;
 956
 957   /* Three types of fields: quoted with ', quoted with ", unquoted. */
 958   if (*cp == '\'' || *cp == '"')
 959     {
 960       int quote = *cp;
 961
 962       *ret_cp = ++cp;
 963       while (cp < ep && *cp != quote)
 964         cp++;
 965       *ret_len = cp - *ret_cp;
 966       if (cp < ep)
 967         cp++;
 968       else
 969         msg (SW, _("Scope of string exceeds line."));
 970     }
 971   else
 972     {
 973       *ret_cp = cp;
 974       while (cp < ep && !isspace ((unsigned char) *cp) && *cp != ',')
 975         cp++;
 976       *ret_len = cp - *ret_cp;
 977     }
 978
 979   {
 980     int beginning_column;
 981
 982     dfm_set_record (dls->handle, *ret_cp);
 983     beginning_column = dfm_get_cur_col (dls->handle) + 1;
 984
 985     dfm_set_record (dls->handle, cp);
 986
 987     return beginning_column;
 988   }
 989 }
 990
 991 typedef int data_list_read_func (const struct data_list_pgm *, struct ccase *);
 992 static data_list_read_func read_from_data_list_fixed;
 993 static data_list_read_func read_from_data_list_free;
 994 static data_list_read_func read_from_data_list_list;
 995
 996 /* Returns the proper function to read the kind of DATA LIST
 997    data specified by DLS. */
 998 static data_list_read_func *
 999 get_data_list_read_func (const struct data_list_pgm *dls)
1000 {
1001   switch (dls->type)
1002     {
1003     case DLS_FIXED:
1004       return read_from_data_list_fixed;
1005
1006     case DLS_FREE:
1007       return read_from_data_list_free;
1008
1009     case DLS_LIST:
1010       return read_from_data_list_list;
1011
1012     default:
1013       assert (0);
1014     }
1015 }
1016
1017 /* Reads a case from the data file into C, parsing it according
1018    to fixed-format syntax rules in DLS.  Returns -1 on success,
1019    -2 at end of file. */
1020 static int
1021 read_from_data_list_fixed (const struct data_list_pgm *dls,
1022                            struct ccase *c)
1023 {
1024   struct dls_var_spec *var_spec = dls->first;
1025   int i;
1026
1027   if (!dfm_get_record (dls->handle, NULL))
1028     return -2;
1029   for (i = 1; i <= dls->nrec; i++)
1030     {
1031       int len;
1032       char *line = dfm_get_record (dls->handle, &len);
1033
1034       if (!line)
1035         {
1036           /* Note that this can't occur on the first record. */
1037           msg (SW, _("Partial case of %d of %d records discarded."),
1038                i - 1, dls->nrec);
1039           return -2;
1040         }
1041
1042       for (; var_spec && i == var_spec->rec; var_spec = var_spec->next)
1043         {
1044           struct data_in di;
1045
1046           data_in_finite_line (&di, line, len, var_spec->fc, var_spec->lc);
1047           di.v = &c->data[var_spec->fv];
1048           di.flags = 0;
1049           di.f1 = var_spec->fc;
1050           di.format = var_spec->input;
1051
1052           data_in (&di);
1053         }
1054
1055       dfm_fwd_record (dls->handle);
1056     }
1057
1058   return -1;
1059 }
1060
1061 /* Reads a case from the data file into C, parsing it according
1062    to free-format syntax rules in DLS.  Returns -1 on success,
1063    -2 at end of file. */
1064 static int
1065 read_from_data_list_free (const struct data_list_pgm *dls,
1066                           struct ccase *c)
1067 {
1068   struct dls_var_spec *var_spec;
1069   char *field;
1070   int len;
1071
1072   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1073     {
1074       int column;
1075
1076       /* Cut out a field and read in a new record if necessary. */
1077       for (;;)
1078         {
1079           column = cut_field (dls, &field, &len);
1080           if (column != 0)
1081             break;
1082
1083           if (dfm_get_record (dls->handle, NULL))
1084             dfm_fwd_record (dls->handle);
1085           if (!dfm_get_record (dls->handle, NULL))
1086             {
1087               if (var_spec != dls->first)
1088                 msg (SW, _("Partial case discarded.  The first variable "
1089                      "missing was %s."), var_spec->name);
1090               return -2;
1091             }
1092         }
1093
1094       {
1095         struct data_in di;
1096
1097         di.s = field;
1098         di.e = field + len;
1099         di.v = &c->data[var_spec->fv];
1100         di.flags = 0;
1101         di.f1 = column;
1102         di.format = var_spec->input;
1103         data_in (&di);
1104       }
1105     }
1106   return -1;
1107 }
1108
1109 /* Reads a case from the data file and parses it according to
1110    list-format syntax rules.  Returns -1 on success, -2 at end of
1111    file. */
1112 static int
1113 read_from_data_list_list (const struct data_list_pgm *dls,
1114                           struct ccase *c)
1115 {
1116   struct dls_var_spec *var_spec;
1117   char *field;
1118   int len;
1119
1120   if (!dfm_get_record (dls->handle, NULL))
1121     return -2;
1122
1123   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1124     {
1125       /* Cut out a field and check for end-of-line. */
1126       int column = cut_field (dls, &field, &len);
1127
1128       if (column == 0)
1129         {
1130           if (get_undefined() )
1131             msg (SW, _("Missing value(s) for all variables from %s onward.  "
1132                  "These will be filled with the system-missing value "
1133                  "or blanks, as appropriate."),
1134                  var_spec->name);
1135           for (; var_spec; var_spec = var_spec->next)
1136             {
1137               int width = get_format_var_width (&var_spec->input);
1138               if (width == 0)
1139                 c->data[var_spec->fv].f = SYSMIS;
1140               else
1141                 memset (c->data[var_spec->fv].s, ' ', width);
1142             }
1143           break;
1144         }
1145
1146       {
1147         struct data_in di;
1148
1149         di.s = field;
1150         di.e = field + len;
1151         di.v = &c->data[var_spec->fv];
1152         di.flags = 0;
1153         di.f1 = column;
1154         di.format = var_spec->input;
1155         data_in (&di);
1156       }
1157     }
1158
1159   dfm_fwd_record (dls->handle);
1160   return -1;
1161 }
1162
1163 /* Destroys SPEC. */
1164 static void
1165 destroy_dls_var_spec (struct dls_var_spec *spec)
1166 {
1167   struct dls_var_spec *next;
1168
1169   while (spec != NULL)
1170     {
1171       next = spec->next;
1172       free (spec);
1173       spec = next;
1174     }
1175 }
1176
1177 /* Destroys DATA LIST transformation PGM. */
1178 static void
1179 data_list_trns_free (struct trns_header *pgm)
1180 {
1181   struct data_list_pgm *dls = (struct data_list_pgm *) pgm;
1182   destroy_dls_var_spec (dls->first);
1183   fh_close_handle (dls->handle);
1184   free (pgm);
1185 }
1186
1187 /* Handle DATA LIST transformation T, parsing data into C. */
1188 static int
1189 data_list_trns_proc (struct trns_header *t, struct ccase *c,
1190                      int case_num UNUSED)
1191 {
1192   struct data_list_pgm *dls = (struct data_list_pgm *) t;
1193   data_list_read_func *read_func;
1194   int retval;
1195
1196   dfm_push (dls->handle);
1197
1198   read_func = get_data_list_read_func (dls);
1199   retval = read_func (dls, c);
1200
1201   /* Handle end of file. */
1202   if (retval == -2)
1203     {
1204       /* If we already encountered end of file then this is an
1205          error. */
1206       if (dls->eof == 1)
1207         {
1208           msg (SE, _("Attempt to read past end of file."));
1209           err_failure ();
1210           dfm_pop (dls->handle);
1211           return -2;
1212         }
1213
1214       /* Otherwise simply note it. */
1215       dls->eof = 1;
1216     }
1217   else
1218     dls->eof = 0;
1219
1220   /* If there was an END subcommand handle it. */
1221   if (dls->end != NULL)
1222     {
1223       if (retval == -2)
1224         {
1225           c->data[dls->end->fv].f = 1.0;
1226           retval = -1;
1227         }
1228       else
1229         c->data[dls->end->fv].f = 0.0;
1230     }
1231
1232   dfm_pop (dls->handle);
1233
1234   return retval;
1235 }
1236 \f
1237 /* Reads all the records from the data file and passes them to
1238    write_case(). */
1239 static void
1240 data_list_source_read (struct case_source *source,
1241                        struct ccase *c,
1242                        write_case_func *write_case, write_case_data wc_data)
1243 {
1244   struct data_list_pgm *dls = source->aux;
1245   data_list_read_func *read_func = get_data_list_read_func (dls);
1246
1247   dfm_push (dls->handle);
1248   while (read_func (dls, c) != -2)
1249     if (!write_case (wc_data))
1250       break;
1251   dfm_pop (dls->handle);
1252
1253   fh_close_handle (dls->handle);
1254 }
1255
1256 /* Destroys the source's internal data. */
1257 static void
1258 data_list_source_destroy (struct case_source *source)
1259 {
1260   data_list_trns_free (source->aux);
1261 }
1262
1263 const struct case_source_class data_list_source_class =
1264   {
1265     "DATA LIST",
1266     NULL,
1267     data_list_source_read,
1268     data_list_source_destroy,
1269   };
1270 \f
1271 /* REPEATING DATA. */
1272
1273 /* Represents a number or a variable. */
1274 struct rpd_num_or_var
1275   {
1276     int num;                    /* Value, or 0. */
1277     struct variable *var;       /* Variable, if number==0. */
1278   };
1279
1280 /* REPEATING DATA private data structure. */
1281 struct repeating_data_trns
1282   {
1283     struct trns_header h;
1284     struct dls_var_spec *first, *last;  /* Variable parsing specifications. */
1285     struct file_handle *handle; /* Input file, never NULL. */
1286
1287     struct rpd_num_or_var starts_beg;   /* STARTS=, before the dash. */
1288     struct rpd_num_or_var starts_end;   /* STARTS=, after the dash. */
1289     struct rpd_num_or_var occurs;       /* OCCURS= subcommand. */
1290     struct rpd_num_or_var length;       /* LENGTH= subcommand. */
1291     struct rpd_num_or_var cont_beg;     /* CONTINUED=, before the dash. */
1292     struct rpd_num_or_var cont_end;     /* CONTINUED=, after the dash. */
1293
1294     /* ID subcommand. */
1295     int id_beg, id_end;                 /* Beginning & end columns. */
1296     struct variable *id_var;            /* DATA LIST variable. */
1297     struct fmt_spec id_spec;            /* Input format spec. */
1298     union value *id_value;              /* ID value. */
1299
1300     write_case_func *write_case;
1301     write_case_data wc_data;
1302   };
1303
1304 static trns_free_func repeating_data_trns_free;
1305 static int parse_num_or_var (struct rpd_num_or_var *, const char *);
1306 static int parse_repeating_data (struct dls_var_spec **,
1307                                  struct dls_var_spec **);
1308 static void find_variable_input_spec (struct variable *v,
1309                                       struct fmt_spec *spec);
1310
1311 /* Parses the REPEATING DATA command. */
1312 int
1313 cmd_repeating_data (void)
1314 {
1315   struct repeating_data_trns *rpd;
1316
1317   /* 0=print no table, 1=print table.  (TABLE subcommand.)  */
1318   int table = 1;
1319
1320   /* Bits are set when a particular subcommand has been seen. */
1321   unsigned seen = 0;
1322
1323   assert (case_source_is_complex (vfm_source));
1324
1325   rpd = xmalloc (sizeof *rpd);
1326   rpd->handle = default_handle;
1327   rpd->first = rpd->last = NULL;
1328   rpd->starts_beg.num = 0;
1329   rpd->starts_beg.var = NULL;
1330   rpd->starts_end = rpd->occurs = rpd->length = rpd->cont_beg
1331     = rpd->cont_end = rpd->starts_beg;
1332   rpd->id_beg = rpd->id_end = 0;
1333   rpd->id_var = NULL;
1334   rpd->id_value = NULL;
1335
1336   lex_match ('/');
1337
1338   for (;;)
1339     {
1340       if (lex_match_id ("FILE"))
1341         {
1342           lex_match ('=');
1343           rpd->handle = fh_parse_file_handle ();
1344           if (!rpd->handle)
1345             goto error;
1346           if (rpd->handle != default_handle)
1347             {
1348               msg (SE, _("REPEATING DATA must use the same file as its "
1349                          "corresponding DATA LIST or FILE TYPE."));
1350               goto error;
1351             }
1352         }
1353       else if (lex_match_id ("STARTS"))
1354         {
1355           lex_match ('=');
1356           if (seen & 1)
1357             {
1358               msg (SE, _("%s subcommand given multiple times."),"STARTS");
1359               goto error;
1360             }
1361           seen |= 1;
1362
1363           if (!parse_num_or_var (&rpd->starts_beg, "STARTS beginning column"))
1364             goto error;
1365
1366           lex_negative_to_dash ();
1367           if (lex_match ('-'))
1368             {
1369               if (!parse_num_or_var (&rpd->starts_end, "STARTS ending column"))
1370                 goto error;
1371             } else {
1372               /* Otherwise, rpd->starts_end is left uninitialized.
1373                  This is okay.  We will initialize it later from the
1374                  record length of the file.  We can't do this now
1375                  because we can't be sure that the user has specified
1376                  the file handle yet. */
1377             }
1378
1379           if (rpd->starts_beg.num != 0 && rpd->starts_end.num != 0
1380               && rpd->starts_beg.num > rpd->starts_end.num)
1381             {
1382               msg (SE, _("STARTS beginning column (%d) exceeds "
1383                          "STARTS ending column (%d)."),
1384                    rpd->starts_beg.num, rpd->starts_end.num);
1385               goto error;
1386             }
1387         }
1388       else if (lex_match_id ("OCCURS"))
1389         {
1390           lex_match ('=');
1391           if (seen & 2)
1392             {
1393               msg (SE, _("%s subcommand given multiple times."),"OCCURS");
1394               goto error;
1395             }
1396           seen |= 2;
1397
1398           if (!parse_num_or_var (&rpd->occurs, "OCCURS"))
1399             goto error;
1400         }
1401       else if (lex_match_id ("LENGTH"))
1402         {
1403           lex_match ('=');
1404           if (seen & 4)
1405             {
1406               msg (SE, _("%s subcommand given multiple times."),"LENGTH");
1407               goto error;
1408             }
1409           seen |= 4;
1410
1411           if (!parse_num_or_var (&rpd->length, "LENGTH"))
1412             goto error;
1413         }
1414       else if (lex_match_id ("CONTINUED"))
1415         {
1416           lex_match ('=');
1417           if (seen & 8)
1418             {
1419               msg (SE, _("%s subcommand given multiple times."),"CONTINUED");
1420               goto error;
1421             }
1422           seen |= 8;
1423
1424           if (!lex_match ('/'))
1425             {
1426               if (!parse_num_or_var (&rpd->cont_beg, "CONTINUED beginning column"))
1427                 goto error;
1428
1429               lex_negative_to_dash ();
1430               if (lex_match ('-')
1431                   && !parse_num_or_var (&rpd->cont_end,
1432                                         "CONTINUED ending column"))
1433                 goto error;
1434
1435               if (rpd->cont_beg.num != 0 && rpd->cont_end.num != 0
1436                   && rpd->cont_beg.num > rpd->cont_end.num)
1437                 {
1438                   msg (SE, _("CONTINUED beginning column (%d) exceeds "
1439                              "CONTINUED ending column (%d)."),
1440                        rpd->cont_beg.num, rpd->cont_end.num);
1441                   goto error;
1442                 }
1443             }
1444           else
1445             rpd->cont_beg.num = 1;
1446         }
1447       else if (lex_match_id ("ID"))
1448         {
1449           lex_match ('=');
1450           if (seen & 16)
1451             {
1452               msg (SE, _("%s subcommand given multiple times."),"ID");
1453               goto error;
1454             }
1455           seen |= 16;
1456
1457           if (!lex_force_int ())
1458             goto error;
1459           if (lex_integer () < 1)
1460             {
1461               msg (SE, _("ID beginning column (%ld) must be positive."),
1462                    lex_integer ());
1463               goto error;
1464             }
1465           rpd->id_beg = lex_integer ();
1466
1467           lex_get ();
1468           lex_negative_to_dash ();
1469
1470           if (lex_match ('-'))
1471             {
1472               if (!lex_force_int ())
1473                 goto error;
1474               if (lex_integer () < 1)
1475                 {
1476                   msg (SE, _("ID ending column (%ld) must be positive."),
1477                        lex_integer ());
1478                   goto error;
1479                 }
1480               if (lex_integer () < rpd->id_end)
1481                 {
1482                   msg (SE, _("ID ending column (%ld) cannot be less than "
1483                              "ID beginning column (%d)."),
1484                        lex_integer (), rpd->id_beg);
1485                   goto error;
1486                 }
1487
1488               rpd->id_end = lex_integer ();
1489               lex_get ();
1490             }
1491           else rpd->id_end = rpd->id_beg;
1492
1493           if (!lex_force_match ('='))
1494             goto error;
1495           rpd->id_var = parse_variable ();
1496           if (rpd->id_var == NULL)
1497             goto error;
1498
1499           find_variable_input_spec (rpd->id_var, &rpd->id_spec);
1500           rpd->id_value = xmalloc (sizeof *rpd->id_value * rpd->id_var->nv);
1501         }
1502       else if (lex_match_id ("TABLE"))
1503         table = 1;
1504       else if (lex_match_id ("NOTABLE"))
1505         table = 0;
1506       else if (lex_match_id ("DATA"))
1507         break;
1508       else
1509         {
1510           lex_error (NULL);
1511           goto error;
1512         }
1513
1514       if (!lex_force_match ('/'))
1515         goto error;
1516     }
1517
1518   /* Comes here when DATA specification encountered. */
1519   if ((seen & (1 | 2)) != (1 | 2))
1520     {
1521       if ((seen & 1) == 0)
1522         msg (SE, _("Missing required specification STARTS."));
1523       if ((seen & 2) == 0)
1524         msg (SE, _("Missing required specification OCCURS."));
1525       goto error;
1526     }
1527
1528   /* Enforce ID restriction. */
1529   if ((seen & 16) && !(seen & 8))
1530     {
1531       msg (SE, _("ID specified without CONTINUED."));
1532       goto error;
1533     }
1534
1535   /* Calculate starts_end, cont_end if necessary. */
1536   if (rpd->starts_end.num == 0 && rpd->starts_end.var == NULL)
1537     rpd->starts_end.num = handle_get_record_width (rpd->handle);
1538   if (rpd->cont_end.num == 0 && rpd->starts_end.var == NULL)
1539     rpd->cont_end.num = handle_get_record_width (rpd->handle);
1540
1541   /* Calculate length if possible. */
1542   if ((seen & 4) == 0)
1543     {
1544       struct dls_var_spec *iter;
1545
1546       for (iter = rpd->first; iter; iter = iter->next)
1547         {
1548           if (iter->lc > rpd->length.num)
1549             rpd->length.num = iter->lc;
1550         }
1551       assert (rpd->length.num != 0);
1552     }
1553
1554   lex_match ('=');
1555   if (!parse_repeating_data (&rpd->first, &rpd->last))
1556     goto error;
1557
1558   if (table)
1559     dump_fixed_table (rpd->first, rpd->handle, rpd->last->rec);
1560
1561   {
1562     struct repeating_data_trns *new_trns;
1563
1564     rpd->h.proc = repeating_data_trns_proc;
1565     rpd->h.free = repeating_data_trns_free;
1566
1567     new_trns = xmalloc (sizeof *new_trns);
1568     memcpy (new_trns, &rpd, sizeof *new_trns);
1569     add_transformation ((struct trns_header *) new_trns);
1570   }
1571
1572   return lex_end_of_command ();
1573
1574  error:
1575   destroy_dls_var_spec (rpd->first);
1576   free (rpd->id_value);
1577   return CMD_FAILURE;
1578 }
1579
1580 /* Finds the input format specification for variable V and puts
1581    it in SPEC.  Because of the way that DATA LIST is structured,
1582    this is nontrivial. */
1583 static void
1584 find_variable_input_spec (struct variable *v, struct fmt_spec *spec)
1585 {
1586   int i;
1587
1588   for (i = 0; i < n_trns; i++)
1589     {
1590       struct data_list_pgm *pgm = (struct data_list_pgm *) t_trns[i];
1591
1592       if (pgm->h.proc == data_list_trns_proc)
1593         {
1594           struct dls_var_spec *iter;
1595
1596           for (iter = pgm->first; iter; iter = iter->next)
1597             if (iter->v == v)
1598               {
1599                 *spec = iter->input;
1600                 return;
1601               }
1602         }
1603     }
1604
1605   assert (0);
1606 }
1607
1608 /* Parses a number or a variable name from the syntax file and puts
1609    the results in VALUE.  Ensures that the number is at least 1; else
1610    emits an error based on MESSAGE.  Returns nonzero only if
1611    successful. */
1612 static int
1613 parse_num_or_var (struct rpd_num_or_var *value, const char *message)
1614 {
1615   if (token == T_ID)
1616     {
1617       value->num = 0;
1618       value->var = parse_variable ();
1619       if (value->var == NULL)
1620         return 0;
1621       if (value->var->type == ALPHA)
1622         {
1623           msg (SE, _("String variable not allowed here."));
1624           return 0;
1625         }
1626     }
1627   else if (lex_integer_p ())
1628     {
1629       value->num = lex_integer ();
1630
1631       if (value->num < 1)
1632         {
1633           msg (SE, _("%s (%d) must be at least 1."), message, value->num);
1634           return 0;
1635         }
1636
1637       lex_get ();
1638     } else {
1639       msg (SE, _("Variable or integer expected for %s."), message);
1640       return 0;
1641     }
1642   return 1;
1643 }
1644
1645 /* Parses data specifications for repeating data groups, adding
1646    them to the linked list with head FIRST and tail LAST.
1647    Returns nonzero only if successful.  */
1648 static int
1649 parse_repeating_data (struct dls_var_spec **first, struct dls_var_spec **last)
1650 {
1651   struct fixed_parsing_state fx;
1652   int i;
1653
1654   fx.recno = 0;
1655   fx.sc = 1;
1656
1657   while (token != '.')
1658     {
1659       if (!parse_DATA_LIST_vars (&fx.name, &fx.name_cnt, PV_NONE))
1660         return 0;
1661
1662       if (token == T_NUM)
1663         {
1664           if (!fixed_parse_compatible (&fx, first, last))
1665             goto fail;
1666         }
1667       else if (token == '(')
1668         {
1669           if (!fixed_parse_fortran (&fx, first, last))
1670             goto fail;
1671         }
1672       else
1673         {
1674           msg (SE, _("SPSS-like or FORTRAN-like format "
1675                "specification expected after variable names."));
1676           goto fail;
1677         }
1678
1679       for (i = 0; i < fx.name_cnt; i++)
1680         free (fx.name[i]);
1681       free (fx.name);
1682     }
1683   if (token != '.')
1684     {
1685       lex_error (_("expecting end of command"));
1686       return 0;
1687     }
1688
1689   return 1;
1690
1691  fail:
1692   for (i = 0; i < fx.name_cnt; i++)
1693     free (fx.name[i]);
1694   free (fx.name);
1695   return 0;
1696 }
1697
1698 /* Obtains the real value for rpd_num_or_var N in case C and returns
1699    it.  The valid range is nonnegative numbers, but numbers outside
1700    this range can be returned and should be handled by the caller as
1701    invalid. */
1702 static int
1703 realize_value (struct rpd_num_or_var *n, struct ccase *c)
1704 {
1705   if (n->num > 0)
1706     return n->num;
1707
1708   assert (n->num == 0);
1709   if (n->var != NULL)
1710     {
1711       double v = c->data[n->var->fv].f;
1712
1713       if (v == SYSMIS || v <= INT_MIN || v >= INT_MAX)
1714         return -1;
1715       else
1716         return v;
1717     }
1718   else
1719     return 0;
1720 }
1721
1722 /* Parameter record passed to rpd_parse_record(). */
1723 struct rpd_parse_info
1724   {
1725     struct repeating_data_trns *trns;  /* REPEATING DATA transformation. */
1726     const char *line;   /* Line being parsed. */
1727     size_t len;         /* Line length. */
1728     int beg, end;       /* First and last column of first occurrence. */
1729     int ofs;            /* Column offset between repeated occurrences. */
1730     struct ccase *c;    /* Case to fill in. */
1731     int verify_id;      /* Zero to initialize ID, nonzero to verify it. */
1732     int max_occurs;     /* Max number of occurrences to parse. */
1733   };
1734
1735 /* Parses one record of repeated data and outputs corresponding
1736    cases.  Returns number of occurrences parsed up to the
1737    maximum specified in INFO. */
1738 static int
1739 rpd_parse_record (const struct rpd_parse_info *info)
1740 {
1741   struct repeating_data_trns *t = info->trns;
1742   int cur = info->beg;
1743   int occurrences;
1744
1745   /* Handle record ID values. */
1746   if (t->id_beg != 0)
1747     {
1748       union value id_temp[MAX_ELEMS_PER_VALUE];
1749
1750       /* Parse record ID into V. */
1751       {
1752         struct data_in di;
1753
1754         data_in_finite_line (&di, info->line, info->len, t->id_beg, t->id_end);
1755         di.v = info->verify_id ? id_temp : t->id_value;
1756         di.flags = 0;
1757         di.f1 = t->id_beg;
1758         di.format = t->id_spec;
1759
1760         if (!data_in (&di))
1761           return 0;
1762       }
1763
1764       if (info->verify_id
1765           && compare_values (id_temp, t->id_value, t->id_var->width) != 0)
1766         {
1767           char expected_str [MAX_FORMATTED_LEN + 1];
1768           char actual_str [MAX_FORMATTED_LEN + 1];
1769
1770           data_out (expected_str, &t->id_var->print, t->id_value);
1771           expected_str[t->id_var->print.w] = '\0';
1772
1773           data_out (actual_str, &t->id_var->print, id_temp);
1774           actual_str[t->id_var->print.w] = '\0';
1775
1776           tmsg (SE, RPD_ERR,
1777                 _("Encountered mismatched record ID \"%s\" expecting \"%s\"."),
1778                 actual_str, expected_str);
1779
1780           return 0;
1781         }
1782     }
1783
1784   /* Iterate over the set of expected occurrences and record each of
1785      them as a separate case.  FIXME: We need to execute any
1786      transformations that follow the current one. */
1787   {
1788     int warned = 0;
1789
1790     for (occurrences = 0; occurrences < info->max_occurs; )
1791       {
1792         if (cur + info->ofs > info->end + 1)
1793           break;
1794         occurrences++;
1795
1796         {
1797           struct dls_var_spec *var_spec = t->first;
1798
1799           for (; var_spec; var_spec = var_spec->next)
1800             {
1801               int fc = var_spec->fc - 1 + cur;
1802               int lc = var_spec->lc - 1 + cur;
1803
1804               if (fc > info->len && !warned && var_spec->input.type != FMT_A)
1805                 {
1806                   warned = 1;
1807
1808                   tmsg (SW, RPD_ERR,
1809                         _("Variable %s starting in column %d extends "
1810                           "beyond physical record length of %d."),
1811                         var_spec->v->name, fc, info->len);
1812                 }
1813
1814               {
1815                 struct data_in di;
1816
1817                 data_in_finite_line (&di, info->line, info->len, fc, lc);
1818                 di.v = &info->c->data[var_spec->fv];
1819                 di.flags = 0;
1820                 di.f1 = fc + 1;
1821                 di.format = var_spec->input;
1822
1823                 if (!data_in (&di))
1824                   return 0;
1825               }
1826             }
1827         }
1828
1829         cur += info->ofs;
1830
1831         if (!t->write_case (t->wc_data))
1832           return 0;
1833       }
1834   }
1835
1836   return occurrences;
1837 }
1838
1839 /* Reads one set of repetitions of the elements in the REPEATING
1840    DATA structure.  Returns -1 on success, -2 on end of file or
1841    on failure. */
1842 int
1843 repeating_data_trns_proc (struct trns_header *trns, struct ccase *c,
1844                           int case_num UNUSED)
1845 {
1846   struct repeating_data_trns *t = (struct repeating_data_trns *) trns;
1847
1848   char *line;           /* Current record. */
1849   int len;              /* Length of current record. */
1850
1851   int starts_beg;       /* Starting column. */
1852   int starts_end;       /* Ending column. */
1853   int occurs;           /* Number of repetitions. */
1854   int length;           /* Length of each occurrence. */
1855   int cont_beg; /* Starting column for continuation lines. */
1856   int cont_end; /* Ending column for continuation lines. */
1857
1858   int occurs_left;      /* Number of occurrences remaining. */
1859
1860   int code;             /* Return value from rpd_parse_record(). */
1861
1862   int skip_first_record = 0;
1863
1864   dfm_push (t->handle);
1865
1866   /* Read the current record. */
1867   dfm_bkwd_record (t->handle, 1);
1868   line = dfm_get_record (t->handle, &len);
1869   if (line == NULL)
1870     return -2;
1871   dfm_fwd_record (t->handle);
1872
1873   /* Calculate occurs, length. */
1874   occurs_left = occurs = realize_value (&t->occurs, c);
1875   if (occurs <= 0)
1876     {
1877       tmsg (SE, RPD_ERR, _("Invalid value %d for OCCURS."), occurs);
1878       return -3;
1879     }
1880   starts_beg = realize_value (&t->starts_beg, c);
1881   if (starts_beg <= 0)
1882     {
1883       tmsg (SE, RPD_ERR, _("Beginning column for STARTS (%d) must be "
1884                            "at least 1."),
1885             starts_beg);
1886       return -3;
1887     }
1888   starts_end = realize_value (&t->starts_end, c);
1889   if (starts_end < starts_beg)
1890     {
1891       tmsg (SE, RPD_ERR, _("Ending column for STARTS (%d) is less than "
1892                            "beginning column (%d)."),
1893             starts_end, starts_beg);
1894       skip_first_record = 1;
1895     }
1896   length = realize_value (&t->length, c);
1897   if (length < 0)
1898     {
1899       tmsg (SE, RPD_ERR, _("Invalid value %d for LENGTH."), length);
1900       length = 1;
1901       occurs = occurs_left = 1;
1902     }
1903   cont_beg = realize_value (&t->cont_beg, c);
1904   if (cont_beg < 0)
1905     {
1906       tmsg (SE, RPD_ERR, _("Beginning column for CONTINUED (%d) must be "
1907                            "at least 1."),
1908             cont_beg);
1909       return -2;
1910     }
1911   cont_end = realize_value (&t->cont_end, c);
1912   if (cont_end < cont_beg)
1913     {
1914       tmsg (SE, RPD_ERR, _("Ending column for CONTINUED (%d) is less than "
1915                            "beginning column (%d)."),
1916             cont_end, cont_beg);
1917       return -2;
1918     }
1919
1920   /* Parse the first record. */
1921   if (!skip_first_record)
1922     {
1923       struct rpd_parse_info info;
1924       info.trns = t;
1925       info.line = line;
1926       info.len = len;
1927       info.beg = starts_beg;
1928       info.end = starts_end;
1929       info.ofs = length;
1930       info.c = c;
1931       info.verify_id = 0;
1932       info.max_occurs = occurs_left;
1933       code = rpd_parse_record (&info);
1934       if (!code)
1935         return -2;
1936       occurs_left -= code;
1937     }
1938   else if (cont_beg == 0)
1939     return -3;
1940
1941   /* Make sure, if some occurrences are left, that we have
1942      continuation records. */
1943   if (occurs_left > 0 && cont_beg == 0)
1944     {
1945       tmsg (SE, RPD_ERR,
1946             _("Number of repetitions specified on OCCURS (%d) "
1947               "exceed number of repetitions available in "
1948               "space on STARTS (%d), and CONTINUED not specified."),
1949             occurs, (starts_end - starts_beg + 1) / length);
1950       return -2;
1951     }
1952
1953   /* Go on to additional records. */
1954   while (occurs_left != 0)
1955     {
1956       struct rpd_parse_info info;
1957
1958       assert (occurs_left >= 0);
1959
1960       /* Read in another record. */
1961       line = dfm_get_record (t->handle, &len);
1962       if (line == NULL)
1963         {
1964           tmsg (SE, RPD_ERR,
1965                 _("Unexpected end of file with %d repetitions "
1966                   "remaining out of %d."),
1967                 occurs_left, occurs);
1968           return -2;
1969         }
1970       dfm_fwd_record (t->handle);
1971
1972       /* Parse this record. */
1973       info.trns = t;
1974       info.line = line;
1975       info.len = len;
1976       info.beg = cont_beg;
1977       info.end = cont_end;
1978       info.ofs = length;
1979       info.c = c;
1980       info.verify_id = 1;
1981       info.max_occurs = occurs_left;
1982       code = rpd_parse_record (&info);;
1983       if (!code)
1984         return -2;
1985       occurs_left -= code;
1986     }
1987
1988   dfm_pop (t->handle);
1989
1990   /* FIXME: This is a kluge until we've implemented multiplexing of
1991      transformations. */
1992   return -3;
1993 }
1994
1995 /* Frees a REPEATING DATA transformation. */
1996 void
1997 repeating_data_trns_free (struct trns_header *rpd_)
1998 {
1999   struct repeating_data_trns *rpd = (struct repeating_data_trns *) rpd_;
2000
2001   destroy_dls_var_spec (rpd->first);
2002   fh_close_handle (rpd->handle);
2003   free (rpd->id_value);
2004 }
2005
2006 /* Lets repeating_data_trns_proc() know how to write the cases
2007    that it composes.  Not elegant. */
2008 void
2009 repeating_data_set_write_case (struct trns_header *trns,
2010                                write_case_func *write_case,
2011                                write_case_data wc_data)
2012 {
2013   struct repeating_data_trns *t = (struct repeating_data_trns *) trns;
2014
2015   assert (trns->proc == repeating_data_trns_proc);
2016   t->write_case = write_case;
2017   t->wc_data = wc_data;
2018 }