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