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       abort ();
1015     }
1016 }
1017
1018 /* Reads a case from the data file into C, parsing it according
1019    to fixed-format syntax rules in DLS.  Returns -1 on success,
1020    -2 at end of file. */
1021 static int
1022 read_from_data_list_fixed (const struct data_list_pgm *dls,
1023                            struct ccase *c)
1024 {
1025   struct dls_var_spec *var_spec = dls->first;
1026   int i;
1027
1028   if (!dfm_get_record (dls->handle, NULL))
1029     return -2;
1030   for (i = 1; i <= dls->nrec; i++)
1031     {
1032       int len;
1033       char *line = dfm_get_record (dls->handle, &len);
1034
1035       if (!line)
1036         {
1037           /* Note that this can't occur on the first record. */
1038           msg (SW, _("Partial case of %d of %d records discarded."),
1039                i - 1, dls->nrec);
1040           return -2;
1041         }
1042
1043       for (; var_spec && i == var_spec->rec; var_spec = var_spec->next)
1044         {
1045           struct data_in di;
1046
1047           data_in_finite_line (&di, line, len, var_spec->fc, var_spec->lc);
1048           di.v = &c->data[var_spec->fv];
1049           di.flags = 0;
1050           di.f1 = var_spec->fc;
1051           di.format = var_spec->input;
1052
1053           data_in (&di);
1054         }
1055
1056       dfm_fwd_record (dls->handle);
1057     }
1058
1059   return -1;
1060 }
1061
1062 /* Reads a case from the data file into C, parsing it according
1063    to free-format syntax rules in DLS.  Returns -1 on success,
1064    -2 at end of file. */
1065 static int
1066 read_from_data_list_free (const struct data_list_pgm *dls,
1067                           struct ccase *c)
1068 {
1069   struct dls_var_spec *var_spec;
1070   char *field;
1071   int len;
1072
1073   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1074     {
1075       int column;
1076
1077       /* Cut out a field and read in a new record if necessary. */
1078       for (;;)
1079         {
1080           column = cut_field (dls, &field, &len);
1081           if (column != 0)
1082             break;
1083
1084           if (dfm_get_record (dls->handle, NULL))
1085             dfm_fwd_record (dls->handle);
1086           if (!dfm_get_record (dls->handle, NULL))
1087             {
1088               if (var_spec != dls->first)
1089                 msg (SW, _("Partial case discarded.  The first variable "
1090                      "missing was %s."), var_spec->name);
1091               return -2;
1092             }
1093         }
1094
1095       {
1096         struct data_in di;
1097
1098         di.s = field;
1099         di.e = field + len;
1100         di.v = &c->data[var_spec->fv];
1101         di.flags = 0;
1102         di.f1 = column;
1103         di.format = var_spec->input;
1104         data_in (&di);
1105       }
1106     }
1107   return -1;
1108 }
1109
1110 /* Reads a case from the data file and parses it according to
1111    list-format syntax rules.  Returns -1 on success, -2 at end of
1112    file. */
1113 static int
1114 read_from_data_list_list (const struct data_list_pgm *dls,
1115                           struct ccase *c)
1116 {
1117   struct dls_var_spec *var_spec;
1118   char *field;
1119   int len;
1120
1121   if (!dfm_get_record (dls->handle, NULL))
1122     return -2;
1123
1124   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1125     {
1126       /* Cut out a field and check for end-of-line. */
1127       int column = cut_field (dls, &field, &len);
1128
1129       if (column == 0)
1130         {
1131           if (get_undefined() )
1132             msg (SW, _("Missing value(s) for all variables from %s onward.  "
1133                  "These will be filled with the system-missing value "
1134                  "or blanks, as appropriate."),
1135                  var_spec->name);
1136           for (; var_spec; var_spec = var_spec->next)
1137             {
1138               int width = get_format_var_width (&var_spec->input);
1139               if (width == 0)
1140                 c->data[var_spec->fv].f = SYSMIS;
1141               else
1142                 memset (c->data[var_spec->fv].s, ' ', width);
1143             }
1144           break;
1145         }
1146
1147       {
1148         struct data_in di;
1149
1150         di.s = field;
1151         di.e = field + len;
1152         di.v = &c->data[var_spec->fv];
1153         di.flags = 0;
1154         di.f1 = column;
1155         di.format = var_spec->input;
1156         data_in (&di);
1157       }
1158     }
1159
1160   dfm_fwd_record (dls->handle);
1161   return -1;
1162 }
1163
1164 /* Destroys SPEC. */
1165 static void
1166 destroy_dls_var_spec (struct dls_var_spec *spec)
1167 {
1168   struct dls_var_spec *next;
1169
1170   while (spec != NULL)
1171     {
1172       next = spec->next;
1173       free (spec);
1174       spec = next;
1175     }
1176 }
1177
1178 /* Destroys DATA LIST transformation PGM. */
1179 static void
1180 data_list_trns_free (struct trns_header *pgm)
1181 {
1182   struct data_list_pgm *dls = (struct data_list_pgm *) pgm;
1183   destroy_dls_var_spec (dls->first);
1184   fh_close_handle (dls->handle);
1185   free (pgm);
1186 }
1187
1188 /* Handle DATA LIST transformation T, parsing data into C. */
1189 static int
1190 data_list_trns_proc (struct trns_header *t, struct ccase *c,
1191                      int case_num UNUSED)
1192 {
1193   struct data_list_pgm *dls = (struct data_list_pgm *) t;
1194   data_list_read_func *read_func;
1195   int retval;
1196
1197   dfm_push (dls->handle);
1198
1199   read_func = get_data_list_read_func (dls);
1200   retval = read_func (dls, c);
1201
1202   /* Handle end of file. */
1203   if (retval == -2)
1204     {
1205       /* If we already encountered end of file then this is an
1206          error. */
1207       if (dls->eof == 1)
1208         {
1209           msg (SE, _("Attempt to read past end of file."));
1210           err_failure ();
1211           dfm_pop (dls->handle);
1212           return -2;
1213         }
1214
1215       /* Otherwise simply note it. */
1216       dls->eof = 1;
1217     }
1218   else
1219     dls->eof = 0;
1220
1221   /* If there was an END subcommand handle it. */
1222   if (dls->end != NULL)
1223     {
1224       if (retval == -2)
1225         {
1226           c->data[dls->end->fv].f = 1.0;
1227           retval = -1;
1228         }
1229       else
1230         c->data[dls->end->fv].f = 0.0;
1231     }
1232
1233   dfm_pop (dls->handle);
1234
1235   return retval;
1236 }
1237 \f
1238 /* Reads all the records from the data file and passes them to
1239    write_case(). */
1240 static void
1241 data_list_source_read (struct case_source *source,
1242                        struct ccase *c,
1243                        write_case_func *write_case, write_case_data wc_data)
1244 {
1245   struct data_list_pgm *dls = source->aux;
1246   data_list_read_func *read_func = get_data_list_read_func (dls);
1247
1248   dfm_push (dls->handle);
1249   while (read_func (dls, c) != -2)
1250     if (!write_case (wc_data))
1251       break;
1252   dfm_pop (dls->handle);
1253
1254   fh_close_handle (dls->handle);
1255 }
1256
1257 /* Destroys the source's internal data. */
1258 static void
1259 data_list_source_destroy (struct case_source *source)
1260 {
1261   data_list_trns_free (source->aux);
1262 }
1263
1264 const struct case_source_class data_list_source_class =
1265   {
1266     "DATA LIST",
1267     NULL,
1268     data_list_source_read,
1269     data_list_source_destroy,
1270   };
1271 \f
1272 /* REPEATING DATA. */
1273
1274 /* Represents a number or a variable. */
1275 struct rpd_num_or_var
1276   {
1277     int num;                    /* Value, or 0. */
1278     struct variable *var;       /* Variable, if number==0. */
1279   };
1280
1281 /* REPEATING DATA private data structure. */
1282 struct repeating_data_trns
1283   {
1284     struct trns_header h;
1285     struct dls_var_spec *first, *last;  /* Variable parsing specifications. */
1286     struct file_handle *handle; /* Input file, never NULL. */
1287
1288     struct rpd_num_or_var starts_beg;   /* STARTS=, before the dash. */
1289     struct rpd_num_or_var starts_end;   /* STARTS=, after the dash. */
1290     struct rpd_num_or_var occurs;       /* OCCURS= subcommand. */
1291     struct rpd_num_or_var length;       /* LENGTH= subcommand. */
1292     struct rpd_num_or_var cont_beg;     /* CONTINUED=, before the dash. */
1293     struct rpd_num_or_var cont_end;     /* CONTINUED=, after the dash. */
1294
1295     /* ID subcommand. */
1296     int id_beg, id_end;                 /* Beginning & end columns. */
1297     struct variable *id_var;            /* DATA LIST variable. */
1298     struct fmt_spec id_spec;            /* Input format spec. */
1299     union value *id_value;              /* ID value. */
1300
1301     write_case_func *write_case;
1302     write_case_data wc_data;
1303   };
1304
1305 static trns_free_func repeating_data_trns_free;
1306 static int parse_num_or_var (struct rpd_num_or_var *, const char *);
1307 static int parse_repeating_data (struct dls_var_spec **,
1308                                  struct dls_var_spec **);
1309 static void find_variable_input_spec (struct variable *v,
1310                                       struct fmt_spec *spec);
1311
1312 /* Parses the REPEATING DATA command. */
1313 int
1314 cmd_repeating_data (void)
1315 {
1316   struct repeating_data_trns *rpd;
1317
1318   /* 0=print no table, 1=print table.  (TABLE subcommand.)  */
1319   int table = 1;
1320
1321   /* Bits are set when a particular subcommand has been seen. */
1322   unsigned seen = 0;
1323
1324   assert (case_source_is_complex (vfm_source));
1325
1326   rpd = xmalloc (sizeof *rpd);
1327   rpd->handle = default_handle;
1328   rpd->first = rpd->last = NULL;
1329   rpd->starts_beg.num = 0;
1330   rpd->starts_beg.var = NULL;
1331   rpd->starts_end = rpd->occurs = rpd->length = rpd->cont_beg
1332     = rpd->cont_end = rpd->starts_beg;
1333   rpd->id_beg = rpd->id_end = 0;
1334   rpd->id_var = NULL;
1335   rpd->id_value = NULL;
1336
1337   lex_match ('/');
1338
1339   for (;;)
1340     {
1341       if (lex_match_id ("FILE"))
1342         {
1343           lex_match ('=');
1344           rpd->handle = fh_parse_file_handle ();
1345           if (!rpd->handle)
1346             goto error;
1347           if (rpd->handle != default_handle)
1348             {
1349               msg (SE, _("REPEATING DATA must use the same file as its "
1350                          "corresponding DATA LIST or FILE TYPE."));
1351               goto error;
1352             }
1353         }
1354       else if (lex_match_id ("STARTS"))
1355         {
1356           lex_match ('=');
1357           if (seen & 1)
1358             {
1359               msg (SE, _("%s subcommand given multiple times."),"STARTS");
1360               goto error;
1361             }
1362           seen |= 1;
1363
1364           if (!parse_num_or_var (&rpd->starts_beg, "STARTS beginning column"))
1365             goto error;
1366
1367           lex_negative_to_dash ();
1368           if (lex_match ('-'))
1369             {
1370               if (!parse_num_or_var (&rpd->starts_end, "STARTS ending column"))
1371                 goto error;
1372             } else {
1373               /* Otherwise, rpd->starts_end is left uninitialized.
1374                  This is okay.  We will initialize it later from the
1375                  record length of the file.  We can't do this now
1376                  because we can't be sure that the user has specified
1377                  the file handle yet. */
1378             }
1379
1380           if (rpd->starts_beg.num != 0 && rpd->starts_end.num != 0
1381               && rpd->starts_beg.num > rpd->starts_end.num)
1382             {
1383               msg (SE, _("STARTS beginning column (%d) exceeds "
1384                          "STARTS ending column (%d)."),
1385                    rpd->starts_beg.num, rpd->starts_end.num);
1386               goto error;
1387             }
1388         }
1389       else if (lex_match_id ("OCCURS"))
1390         {
1391           lex_match ('=');
1392           if (seen & 2)
1393             {
1394               msg (SE, _("%s subcommand given multiple times."),"OCCURS");
1395               goto error;
1396             }
1397           seen |= 2;
1398
1399           if (!parse_num_or_var (&rpd->occurs, "OCCURS"))
1400             goto error;
1401         }
1402       else if (lex_match_id ("LENGTH"))
1403         {
1404           lex_match ('=');
1405           if (seen & 4)
1406             {
1407               msg (SE, _("%s subcommand given multiple times."),"LENGTH");
1408               goto error;
1409             }
1410           seen |= 4;
1411
1412           if (!parse_num_or_var (&rpd->length, "LENGTH"))
1413             goto error;
1414         }
1415       else if (lex_match_id ("CONTINUED"))
1416         {
1417           lex_match ('=');
1418           if (seen & 8)
1419             {
1420               msg (SE, _("%s subcommand given multiple times."),"CONTINUED");
1421               goto error;
1422             }
1423           seen |= 8;
1424
1425           if (!lex_match ('/'))
1426             {
1427               if (!parse_num_or_var (&rpd->cont_beg, "CONTINUED beginning column"))
1428                 goto error;
1429
1430               lex_negative_to_dash ();
1431               if (lex_match ('-')
1432                   && !parse_num_or_var (&rpd->cont_end,
1433                                         "CONTINUED ending column"))
1434                 goto error;
1435
1436               if (rpd->cont_beg.num != 0 && rpd->cont_end.num != 0
1437                   && rpd->cont_beg.num > rpd->cont_end.num)
1438                 {
1439                   msg (SE, _("CONTINUED beginning column (%d) exceeds "
1440                              "CONTINUED ending column (%d)."),
1441                        rpd->cont_beg.num, rpd->cont_end.num);
1442                   goto error;
1443                 }
1444             }
1445           else
1446             rpd->cont_beg.num = 1;
1447         }
1448       else if (lex_match_id ("ID"))
1449         {
1450           lex_match ('=');
1451           if (seen & 16)
1452             {
1453               msg (SE, _("%s subcommand given multiple times."),"ID");
1454               goto error;
1455             }
1456           seen |= 16;
1457
1458           if (!lex_force_int ())
1459             goto error;
1460           if (lex_integer () < 1)
1461             {
1462               msg (SE, _("ID beginning column (%ld) must be positive."),
1463                    lex_integer ());
1464               goto error;
1465             }
1466           rpd->id_beg = lex_integer ();
1467
1468           lex_get ();
1469           lex_negative_to_dash ();
1470
1471           if (lex_match ('-'))
1472             {
1473               if (!lex_force_int ())
1474                 goto error;
1475               if (lex_integer () < 1)
1476                 {
1477                   msg (SE, _("ID ending column (%ld) must be positive."),
1478                        lex_integer ());
1479                   goto error;
1480                 }
1481               if (lex_integer () < rpd->id_end)
1482                 {
1483                   msg (SE, _("ID ending column (%ld) cannot be less than "
1484                              "ID beginning column (%d)."),
1485                        lex_integer (), rpd->id_beg);
1486                   goto error;
1487                 }
1488
1489               rpd->id_end = lex_integer ();
1490               lex_get ();
1491             }
1492           else rpd->id_end = rpd->id_beg;
1493
1494           if (!lex_force_match ('='))
1495             goto error;
1496           rpd->id_var = parse_variable ();
1497           if (rpd->id_var == NULL)
1498             goto error;
1499
1500           find_variable_input_spec (rpd->id_var, &rpd->id_spec);
1501           rpd->id_value = xmalloc (sizeof *rpd->id_value * rpd->id_var->nv);
1502         }
1503       else if (lex_match_id ("TABLE"))
1504         table = 1;
1505       else if (lex_match_id ("NOTABLE"))
1506         table = 0;
1507       else if (lex_match_id ("DATA"))
1508         break;
1509       else
1510         {
1511           lex_error (NULL);
1512           goto error;
1513         }
1514
1515       if (!lex_force_match ('/'))
1516         goto error;
1517     }
1518
1519   /* Comes here when DATA specification encountered. */
1520   if ((seen & (1 | 2)) != (1 | 2))
1521     {
1522       if ((seen & 1) == 0)
1523         msg (SE, _("Missing required specification STARTS."));
1524       if ((seen & 2) == 0)
1525         msg (SE, _("Missing required specification OCCURS."));
1526       goto error;
1527     }
1528
1529   /* Enforce ID restriction. */
1530   if ((seen & 16) && !(seen & 8))
1531     {
1532       msg (SE, _("ID specified without CONTINUED."));
1533       goto error;
1534     }
1535
1536   /* Calculate starts_end, cont_end if necessary. */
1537   if (rpd->starts_end.num == 0 && rpd->starts_end.var == NULL)
1538     rpd->starts_end.num = handle_get_record_width (rpd->handle);
1539   if (rpd->cont_end.num == 0 && rpd->starts_end.var == NULL)
1540     rpd->cont_end.num = handle_get_record_width (rpd->handle);
1541
1542   /* Calculate length if possible. */
1543   if ((seen & 4) == 0)
1544     {
1545       struct dls_var_spec *iter;
1546
1547       for (iter = rpd->first; iter; iter = iter->next)
1548         {
1549           if (iter->lc > rpd->length.num)
1550             rpd->length.num = iter->lc;
1551         }
1552       assert (rpd->length.num != 0);
1553     }
1554
1555   lex_match ('=');
1556   if (!parse_repeating_data (&rpd->first, &rpd->last))
1557     goto error;
1558
1559   if (table)
1560     dump_fixed_table (rpd->first, rpd->handle, rpd->last->rec);
1561
1562   {
1563     struct repeating_data_trns *new_trns;
1564
1565     rpd->h.proc = repeating_data_trns_proc;
1566     rpd->h.free = repeating_data_trns_free;
1567
1568     new_trns = xmalloc (sizeof *new_trns);
1569     memcpy (new_trns, &rpd, sizeof *new_trns);
1570     add_transformation ((struct trns_header *) new_trns);
1571   }
1572
1573   return lex_end_of_command ();
1574
1575  error:
1576   destroy_dls_var_spec (rpd->first);
1577   free (rpd->id_value);
1578   return CMD_FAILURE;
1579 }
1580
1581 /* Finds the input format specification for variable V and puts
1582    it in SPEC.  Because of the way that DATA LIST is structured,
1583    this is nontrivial. */
1584 static void
1585 find_variable_input_spec (struct variable *v, struct fmt_spec *spec)
1586 {
1587   int i;
1588
1589   for (i = 0; i < n_trns; i++)
1590     {
1591       struct data_list_pgm *pgm = (struct data_list_pgm *) t_trns[i];
1592
1593       if (pgm->h.proc == data_list_trns_proc)
1594         {
1595           struct dls_var_spec *iter;
1596
1597           for (iter = pgm->first; iter; iter = iter->next)
1598             if (iter->v == v)
1599               {
1600                 *spec = iter->input;
1601                 return;
1602               }
1603         }
1604     }
1605
1606   assert (0);
1607 }
1608
1609 /* Parses a number or a variable name from the syntax file and puts
1610    the results in VALUE.  Ensures that the number is at least 1; else
1611    emits an error based on MESSAGE.  Returns nonzero only if
1612    successful. */
1613 static int
1614 parse_num_or_var (struct rpd_num_or_var *value, const char *message)
1615 {
1616   if (token == T_ID)
1617     {
1618       value->num = 0;
1619       value->var = parse_variable ();
1620       if (value->var == NULL)
1621         return 0;
1622       if (value->var->type == ALPHA)
1623         {
1624           msg (SE, _("String variable not allowed here."));
1625           return 0;
1626         }
1627     }
1628   else if (lex_integer_p ())
1629     {
1630       value->num = lex_integer ();
1631
1632       if (value->num < 1)
1633         {
1634           msg (SE, _("%s (%d) must be at least 1."), message, value->num);
1635           return 0;
1636         }
1637
1638       lex_get ();
1639     } else {
1640       msg (SE, _("Variable or integer expected for %s."), message);
1641       return 0;
1642     }
1643   return 1;
1644 }
1645
1646 /* Parses data specifications for repeating data groups, adding
1647    them to the linked list with head FIRST and tail LAST.
1648    Returns nonzero only if successful.  */
1649 static int
1650 parse_repeating_data (struct dls_var_spec **first, struct dls_var_spec **last)
1651 {
1652   struct fixed_parsing_state fx;
1653   int i;
1654
1655   fx.recno = 0;
1656   fx.sc = 1;
1657
1658   while (token != '.')
1659     {
1660       if (!parse_DATA_LIST_vars (&fx.name, &fx.name_cnt, PV_NONE))
1661         return 0;
1662
1663       if (token == T_NUM)
1664         {
1665           if (!fixed_parse_compatible (&fx, first, last))
1666             goto fail;
1667         }
1668       else if (token == '(')
1669         {
1670           if (!fixed_parse_fortran (&fx, first, last))
1671             goto fail;
1672         }
1673       else
1674         {
1675           msg (SE, _("SPSS-like or FORTRAN-like format "
1676                "specification expected after variable names."));
1677           goto fail;
1678         }
1679
1680       for (i = 0; i < fx.name_cnt; i++)
1681         free (fx.name[i]);
1682       free (fx.name);
1683     }
1684   if (token != '.')
1685     {
1686       lex_error (_("expecting end of command"));
1687       return 0;
1688     }
1689
1690   return 1;
1691
1692  fail:
1693   for (i = 0; i < fx.name_cnt; i++)
1694     free (fx.name[i]);
1695   free (fx.name);
1696   return 0;
1697 }
1698
1699 /* Obtains the real value for rpd_num_or_var N in case C and returns
1700    it.  The valid range is nonnegative numbers, but numbers outside
1701    this range can be returned and should be handled by the caller as
1702    invalid. */
1703 static int
1704 realize_value (struct rpd_num_or_var *n, struct ccase *c)
1705 {
1706   if (n->num > 0)
1707     return n->num;
1708
1709   assert (n->num == 0);
1710   if (n->var != NULL)
1711     {
1712       double v = c->data[n->var->fv].f;
1713
1714       if (v == SYSMIS || v <= INT_MIN || v >= INT_MAX)
1715         return -1;
1716       else
1717         return v;
1718     }
1719   else
1720     return 0;
1721 }
1722
1723 /* Parameter record passed to rpd_parse_record(). */
1724 struct rpd_parse_info
1725   {
1726     struct repeating_data_trns *trns;  /* REPEATING DATA transformation. */
1727     const char *line;   /* Line being parsed. */
1728     size_t len;         /* Line length. */
1729     int beg, end;       /* First and last column of first occurrence. */
1730     int ofs;            /* Column offset between repeated occurrences. */
1731     struct ccase *c;    /* Case to fill in. */
1732     int verify_id;      /* Zero to initialize ID, nonzero to verify it. */
1733     int max_occurs;     /* Max number of occurrences to parse. */
1734   };
1735
1736 /* Parses one record of repeated data and outputs corresponding
1737    cases.  Returns number of occurrences parsed up to the
1738    maximum specified in INFO. */
1739 static int
1740 rpd_parse_record (const struct rpd_parse_info *info)
1741 {
1742   struct repeating_data_trns *t = info->trns;
1743   int cur = info->beg;
1744   int occurrences;
1745
1746   /* Handle record ID values. */
1747   if (t->id_beg != 0)
1748     {
1749       union value id_temp[MAX_ELEMS_PER_VALUE];
1750
1751       /* Parse record ID into V. */
1752       {
1753         struct data_in di;
1754
1755         data_in_finite_line (&di, info->line, info->len, t->id_beg, t->id_end);
1756         di.v = info->verify_id ? id_temp : t->id_value;
1757         di.flags = 0;
1758         di.f1 = t->id_beg;
1759         di.format = t->id_spec;
1760
1761         if (!data_in (&di))
1762           return 0;
1763       }
1764
1765       if (info->verify_id
1766           && compare_values (id_temp, t->id_value, t->id_var->width) != 0)
1767         {
1768           char expected_str [MAX_FORMATTED_LEN + 1];
1769           char actual_str [MAX_FORMATTED_LEN + 1];
1770
1771           data_out (expected_str, &t->id_var->print, t->id_value);
1772           expected_str[t->id_var->print.w] = '\0';
1773
1774           data_out (actual_str, &t->id_var->print, id_temp);
1775           actual_str[t->id_var->print.w] = '\0';
1776
1777           tmsg (SE, RPD_ERR,
1778                 _("Encountered mismatched record ID \"%s\" expecting \"%s\"."),
1779                 actual_str, expected_str);
1780
1781           return 0;
1782         }
1783     }
1784
1785   /* Iterate over the set of expected occurrences and record each of
1786      them as a separate case.  FIXME: We need to execute any
1787      transformations that follow the current one. */
1788   {
1789     int warned = 0;
1790
1791     for (occurrences = 0; occurrences < info->max_occurs; )
1792       {
1793         if (cur + info->ofs > info->end + 1)
1794           break;
1795         occurrences++;
1796
1797         {
1798           struct dls_var_spec *var_spec = t->first;
1799
1800           for (; var_spec; var_spec = var_spec->next)
1801             {
1802               int fc = var_spec->fc - 1 + cur;
1803               int lc = var_spec->lc - 1 + cur;
1804
1805               if (fc > info->len && !warned && var_spec->input.type != FMT_A)
1806                 {
1807                   warned = 1;
1808
1809                   tmsg (SW, RPD_ERR,
1810                         _("Variable %s starting in column %d extends "
1811                           "beyond physical record length of %d."),
1812                         var_spec->v->name, fc, info->len);
1813                 }
1814
1815               {
1816                 struct data_in di;
1817
1818                 data_in_finite_line (&di, info->line, info->len, fc, lc);
1819                 di.v = &info->c->data[var_spec->fv];
1820                 di.flags = 0;
1821                 di.f1 = fc + 1;
1822                 di.format = var_spec->input;
1823
1824                 if (!data_in (&di))
1825                   return 0;
1826               }
1827             }
1828         }
1829
1830         cur += info->ofs;
1831
1832         if (!t->write_case (t->wc_data))
1833           return 0;
1834       }
1835   }
1836
1837   return occurrences;
1838 }
1839
1840 /* Reads one set of repetitions of the elements in the REPEATING
1841    DATA structure.  Returns -1 on success, -2 on end of file or
1842    on failure. */
1843 int
1844 repeating_data_trns_proc (struct trns_header *trns, struct ccase *c,
1845                           int case_num UNUSED)
1846 {
1847   struct repeating_data_trns *t = (struct repeating_data_trns *) trns;
1848
1849   char *line;           /* Current record. */
1850   int len;              /* Length of current record. */
1851
1852   int starts_beg;       /* Starting column. */
1853   int starts_end;       /* Ending column. */
1854   int occurs;           /* Number of repetitions. */
1855   int length;           /* Length of each occurrence. */
1856   int cont_beg; /* Starting column for continuation lines. */
1857   int cont_end; /* Ending column for continuation lines. */
1858
1859   int occurs_left;      /* Number of occurrences remaining. */
1860
1861   int code;             /* Return value from rpd_parse_record(). */
1862
1863   int skip_first_record = 0;
1864
1865   dfm_push (t->handle);
1866
1867   /* Read the current record. */
1868   dfm_bkwd_record (t->handle, 1);
1869   line = dfm_get_record (t->handle, &len);
1870   if (line == NULL)
1871     return -2;
1872   dfm_fwd_record (t->handle);
1873
1874   /* Calculate occurs, length. */
1875   occurs_left = occurs = realize_value (&t->occurs, c);
1876   if (occurs <= 0)
1877     {
1878       tmsg (SE, RPD_ERR, _("Invalid value %d for OCCURS."), occurs);
1879       return -3;
1880     }
1881   starts_beg = realize_value (&t->starts_beg, c);
1882   if (starts_beg <= 0)
1883     {
1884       tmsg (SE, RPD_ERR, _("Beginning column for STARTS (%d) must be "
1885                            "at least 1."),
1886             starts_beg);
1887       return -3;
1888     }
1889   starts_end = realize_value (&t->starts_end, c);
1890   if (starts_end < starts_beg)
1891     {
1892       tmsg (SE, RPD_ERR, _("Ending column for STARTS (%d) is less than "
1893                            "beginning column (%d)."),
1894             starts_end, starts_beg);
1895       skip_first_record = 1;
1896     }
1897   length = realize_value (&t->length, c);
1898   if (length < 0)
1899     {
1900       tmsg (SE, RPD_ERR, _("Invalid value %d for LENGTH."), length);
1901       length = 1;
1902       occurs = occurs_left = 1;
1903     }
1904   cont_beg = realize_value (&t->cont_beg, c);
1905   if (cont_beg < 0)
1906     {
1907       tmsg (SE, RPD_ERR, _("Beginning column for CONTINUED (%d) must be "
1908                            "at least 1."),
1909             cont_beg);
1910       return -2;
1911     }
1912   cont_end = realize_value (&t->cont_end, c);
1913   if (cont_end < cont_beg)
1914     {
1915       tmsg (SE, RPD_ERR, _("Ending column for CONTINUED (%d) is less than "
1916                            "beginning column (%d)."),
1917             cont_end, cont_beg);
1918       return -2;
1919     }
1920
1921   /* Parse the first record. */
1922   if (!skip_first_record)
1923     {
1924       struct rpd_parse_info info;
1925       info.trns = t;
1926       info.line = line;
1927       info.len = len;
1928       info.beg = starts_beg;
1929       info.end = starts_end;
1930       info.ofs = length;
1931       info.c = c;
1932       info.verify_id = 0;
1933       info.max_occurs = occurs_left;
1934       code = rpd_parse_record (&info);
1935       if (!code)
1936         return -2;
1937       occurs_left -= code;
1938     }
1939   else if (cont_beg == 0)
1940     return -3;
1941
1942   /* Make sure, if some occurrences are left, that we have
1943      continuation records. */
1944   if (occurs_left > 0 && cont_beg == 0)
1945     {
1946       tmsg (SE, RPD_ERR,
1947             _("Number of repetitions specified on OCCURS (%d) "
1948               "exceed number of repetitions available in "
1949               "space on STARTS (%d), and CONTINUED not specified."),
1950             occurs, (starts_end - starts_beg + 1) / length);
1951       return -2;
1952     }
1953
1954   /* Go on to additional records. */
1955   while (occurs_left != 0)
1956     {
1957       struct rpd_parse_info info;
1958
1959       assert (occurs_left >= 0);
1960
1961       /* Read in another record. */
1962       line = dfm_get_record (t->handle, &len);
1963       if (line == NULL)
1964         {
1965           tmsg (SE, RPD_ERR,
1966                 _("Unexpected end of file with %d repetitions "
1967                   "remaining out of %d."),
1968                 occurs_left, occurs);
1969           return -2;
1970         }
1971       dfm_fwd_record (t->handle);
1972
1973       /* Parse this record. */
1974       info.trns = t;
1975       info.line = line;
1976       info.len = len;
1977       info.beg = cont_beg;
1978       info.end = cont_end;
1979       info.ofs = length;
1980       info.c = c;
1981       info.verify_id = 1;
1982       info.max_occurs = occurs_left;
1983       code = rpd_parse_record (&info);;
1984       if (!code)
1985         return -2;
1986       occurs_left -= code;
1987     }
1988
1989   dfm_pop (t->handle);
1990
1991   /* FIXME: This is a kluge until we've implemented multiplexing of
1992      transformations. */
1993   return -3;
1994 }
1995
1996 /* Frees a REPEATING DATA transformation. */
1997 void
1998 repeating_data_trns_free (struct trns_header *rpd_)
1999 {
2000   struct repeating_data_trns *rpd = (struct repeating_data_trns *) rpd_;
2001
2002   destroy_dls_var_spec (rpd->first);
2003   fh_close_handle (rpd->handle);
2004   free (rpd->id_value);
2005 }
2006
2007 /* Lets repeating_data_trns_proc() know how to write the cases
2008    that it composes.  Not elegant. */
2009 void
2010 repeating_data_set_write_case (struct trns_header *trns,
2011                                write_case_func *write_case,
2012                                write_case_data wc_data)
2013 {
2014   struct repeating_data_trns *t = (struct repeating_data_trns *) trns;
2015
2016   assert (trns->proc == repeating_data_trns_proc);
2017   t->write_case = write_case;
2018   t->wc_data = wc_data;
2019 }