src/data-list.c

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