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