src/data-list.c

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