src/language/data-io/data-list.c

   1 /* PSPP - computes sample statistics.
   2    Copyright (C) 1997-9, 2000, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA
  18    02110-1301, USA. */
  19
  20 #include <config.h>
  21
  22 #include <ctype.h>
  23 #include <float.h>
  24 #include <stdio.h>
  25 #include <stdlib.h>
  26
  27 #include <data/case-source.h>
  28 #include <data/case.h>
  29 #include <data/case-source.h>
  30 #include <data/data-in.h>
  31 #include <data/dictionary.h>
  32 #include <data/format.h>
  33 #include <data/procedure.h>
  34 #include <data/settings.h>
  35 #include <data/transformations.h>
  36 #include <data/variable.h>
  37 #include <language/command.h>
  38 #include <language/data-io/data-reader.h>
  39 #include <language/data-io/file-handle.h>
  40 #include <language/data-io/inpt-pgm.h>
  41 #include <language/lexer/lexer.h>
  42 #include <libpspp/alloc.h>
  43 #include <libpspp/compiler.h>
  44 #include <libpspp/message.h>
  45 #include <libpspp/message.h>
  46 #include <libpspp/misc.h>
  47 #include <libpspp/str.h>
  48 #include <output/table.h>
  49
  50 #include "gettext.h"
  51 #define _(msgid) gettext (msgid)
  52 \f
  53 /* Utility function. */
  54
  55 /* Describes how to parse one variable. */
  56 struct dls_var_spec
  57   {
  58     struct dls_var_spec *next;  /* Next specification in list. */
  59
  60     /* Both free and fixed formats. */
  61     struct fmt_spec input;      /* Input format of this field. */
  62     struct variable *v;         /* Associated variable.  Used only in
  63                                    parsing.  Not safe later. */
  64     int fv;                     /* First value in case. */
  65
  66     /* Fixed format only. */
  67     int rec;                    /* Record number (1-based). */
  68     int fc, lc;                 /* Column numbers in record. */
  69
  70     /* Free format only. */
  71     char name[LONG_NAME_LEN + 1]; /* Name of variable. */
  72   };
  73
  74 /* Constants for DATA LIST type. */
  75 /* Must match table in cmd_data_list(). */
  76 enum
  77   {
  78     DLS_FIXED,
  79     DLS_FREE,
  80     DLS_LIST
  81   };
  82
  83 /* DATA LIST private data structure. */
  84 struct data_list_pgm
  85   {
  86     struct dls_var_spec *first, *last;  /* Variable parsing specifications. */
  87     struct dfm_reader *reader;  /* Data file reader. */
  88
  89     int type;                   /* A DLS_* constant. */
  90     struct variable *end;       /* Variable specified on END subcommand. */
  91     int rec_cnt;                /* Number of records. */
  92     size_t case_size;           /* Case size in bytes. */
  93     char *delims;               /* Delimiters if any; not null-terminated. */
  94     size_t delim_cnt;           /* Number of delimiter, or 0 for spaces. */
  95   };
  96
  97 static const struct case_source_class data_list_source_class;
  98
  99 static int parse_fixed (struct data_list_pgm *);
 100 static int parse_free (struct dls_var_spec **, struct dls_var_spec **);
 101 static void dump_fixed_table (const struct dls_var_spec *,
 102                               const struct file_handle *, int rec_cnt);
 103 static void dump_free_table (const struct data_list_pgm *,
 104                              const struct file_handle *);
 105 static void destroy_dls_var_spec (struct dls_var_spec *);
 106
 107 static trns_free_func data_list_trns_free;
 108 static trns_proc_func data_list_trns_proc;
 109
 110 int
 111 cmd_data_list (void)
 112 {
 113   struct data_list_pgm *dls;
 114   int table = -1;                /* Print table if nonzero, -1=undecided. */
 115   struct file_handle *fh = fh_inline_file ();
 116
 117   if (!in_input_program ())
 118     discard_variables ();
 119
 120   dls = xmalloc (sizeof *dls);
 121   dls->reader = NULL;
 122   dls->type = -1;
 123   dls->end = NULL;
 124   dls->rec_cnt = 0;
 125   dls->delims = NULL;
 126   dls->delim_cnt = 0;
 127   dls->first = dls->last = NULL;
 128
 129   while (token != '/')
 130     {
 131       if (lex_match_id ("FILE"))
 132         {
 133           lex_match ('=');
 134           fh = fh_parse (FH_REF_FILE | FH_REF_INLINE);
 135           if (fh == NULL)
 136             goto error;
 137         }
 138       else if (lex_match_id ("RECORDS"))
 139         {
 140           lex_match ('=');
 141           lex_match ('(');
 142           if (!lex_force_int ())
 143             goto error;
 144           dls->rec_cnt = lex_integer ();
 145           lex_get ();
 146           lex_match (')');
 147         }
 148       else if (lex_match_id ("END"))
 149         {
 150           if (dls->end)
 151             {
 152               msg (SE, _("The END subcommand may only be specified once."));
 153               goto error;
 154             }
 155
 156           lex_match ('=');
 157           if (!lex_force_id ())
 158             goto error;
 159           dls->end = dict_lookup_var (default_dict, tokid);
 160           if (!dls->end)
 161             dls->end = dict_create_var_assert (default_dict, tokid, 0);
 162           lex_get ();
 163         }
 164       else if (token == T_ID)
 165         {
 166           if (lex_match_id ("NOTABLE"))
 167             table = 0;
 168           else if (lex_match_id ("TABLE"))
 169             table = 1;
 170           else
 171             {
 172               int type;
 173               if (lex_match_id ("FIXED"))
 174                 type = DLS_FIXED;
 175               else if (lex_match_id ("FREE"))
 176                 type = DLS_FREE;
 177               else if (lex_match_id ("LIST"))
 178                 type = DLS_LIST;
 179               else
 180                 {
 181                   lex_error (NULL);
 182                   goto error;
 183                 }
 184
 185               if (dls->type != -1)
 186                 {
 187                   msg (SE, _("Only one of FIXED, FREE, or LIST may "
 188                              "be specified."));
 189                   goto error;
 190                 }
 191               dls->type = type;
 192
 193               if ((dls->type == DLS_FREE || dls->type == DLS_LIST)
 194                   && lex_match ('('))
 195                 {
 196                   while (!lex_match (')'))
 197                     {
 198                       int delim;
 199
 200                       if (lex_match_id ("TAB"))
 201                         delim = '\t';
 202                       else if (token == T_STRING && tokstr.length == 1)
 203                         {
 204                           delim = tokstr.string[0];
 205                           lex_get();
 206                         }
 207                       else
 208                         {
 209                           lex_error (NULL);
 210                           goto error;
 211                         }
 212
 213                       dls->delims = xrealloc (dls->delims, dls->delim_cnt + 1);
 214                       dls->delims[dls->delim_cnt++] = delim;
 215
 216                       lex_match (',');
 217                     }
 218                 }
 219             }
 220         }
 221       else
 222         {
 223           lex_error (NULL);
 224           goto error;
 225         }
 226     }
 227
 228   dls->case_size = dict_get_case_size (default_dict);
 229   fh_set_default_handle (fh);
 230
 231   if (dls->type == -1)
 232     dls->type = DLS_FIXED;
 233
 234   if (table == -1)
 235     {
 236       if (dls->type == DLS_FREE)
 237         table = 0;
 238       else
 239         table = 1;
 240     }
 241
 242   if (dls->type == DLS_FIXED)
 243     {
 244       if (!parse_fixed (dls))
 245         goto error;
 246       if (table)
 247         dump_fixed_table (dls->first, fh, dls->rec_cnt);
 248     }
 249   else
 250     {
 251       if (!parse_free (&dls->first, &dls->last))
 252         goto error;
 253       if (table)
 254         dump_free_table (dls, fh);
 255     }
 256
 257   dls->reader = dfm_open_reader (fh);
 258   if (dls->reader == NULL)
 259     goto error;
 260
 261   if (in_input_program ())
 262     add_transformation (data_list_trns_proc, data_list_trns_free, dls);
 263   else
 264     proc_set_source (create_case_source (&data_list_source_class, dls));
 265
 266   return CMD_SUCCESS;
 267
 268  error:
 269   data_list_trns_free (dls);
 270   return CMD_CASCADING_FAILURE;
 271 }
 272
 273 /* Adds SPEC to the linked list with head at FIRST and tail at
 274    LAST. */
 275 static void
 276 append_var_spec (struct dls_var_spec **first, struct dls_var_spec **last,
 277                  struct dls_var_spec *spec)
 278 {
 279   spec->next = NULL;
 280
 281   if (*first == NULL)
 282     *first = spec;
 283   else
 284     (*last)->next = spec;
 285   *last = spec;
 286 }
 287 \f
 288 /* Fixed-format parsing. */
 289
 290 /* Used for chaining together fortran-like format specifiers. */
 291 struct fmt_list
 292   {
 293     struct fmt_list *next;
 294     int count;
 295     struct fmt_spec f;
 296     struct fmt_list *down;
 297   };
 298
 299 /* State of parsing DATA LIST. */
 300 struct fixed_parsing_state
 301   {
 302     char **name;                /* Variable names. */
 303     size_t name_cnt;            /* Number of names. */
 304
 305     int recno;                  /* Index of current record. */
 306     int sc;                     /* 1-based column number of starting column for
 307                                    next field to output. */
 308   };
 309
 310 static int fixed_parse_compatible (struct fixed_parsing_state *,
 311                                    struct dls_var_spec **,
 312                                    struct dls_var_spec **);
 313 static int fixed_parse_fortran (struct fixed_parsing_state *,
 314                                 struct dls_var_spec **,
 315                                 struct dls_var_spec **);
 316
 317 /* Parses all the variable specifications for DATA LIST FIXED,
 318    storing them into DLS.  Returns nonzero if successful. */
 319 static int
 320 parse_fixed (struct data_list_pgm *dls)
 321 {
 322   struct fixed_parsing_state fx;
 323   size_t i;
 324
 325   fx.recno = 0;
 326   fx.sc = 1;
 327
 328   while (token != '.')
 329     {
 330       while (lex_match ('/'))
 331         {
 332           fx.recno++;
 333           if (lex_is_integer ())
 334             {
 335               if (lex_integer () < fx.recno)
 336                 {
 337                   msg (SE, _("The record number specified, %ld, is "
 338                              "before the previous record, %d.  Data "
 339                              "fields must be listed in order of "
 340                              "increasing record number."),
 341                        lex_integer (), fx.recno - 1);
 342                   return 0;
 343                 }
 344
 345               fx.recno = lex_integer ();
 346               lex_get ();
 347             }
 348           fx.sc = 1;
 349         }
 350
 351       if (!parse_DATA_LIST_vars (&fx.name, &fx.name_cnt, PV_NONE))
 352         return 0;
 353
 354       if (lex_is_number ())
 355         {
 356           if (!fixed_parse_compatible (&fx, &dls->first, &dls->last))
 357             goto fail;
 358         }
 359       else if (token == '(')
 360         {
 361           if (!fixed_parse_fortran (&fx, &dls->first, &dls->last))
 362             goto fail;
 363         }
 364       else
 365         {
 366           msg (SE, _("SPSS-like or FORTRAN-like format "
 367                      "specification expected after variable names."));
 368           goto fail;
 369         }
 370
 371       for (i = 0; i < fx.name_cnt; i++)
 372         free (fx.name[i]);
 373       free (fx.name);
 374     }
 375   if (dls->first == NULL)
 376     {
 377       msg (SE, _("At least one variable must be specified."));
 378       return 0;
 379     }
 380   if (dls->rec_cnt && dls->last->rec > dls->rec_cnt)
 381     {
 382       msg (SE, _("Variables are specified on records that "
 383                  "should not exist according to RECORDS subcommand."));
 384       return 0;
 385     }
 386   else if (!dls->rec_cnt)
 387     dls->rec_cnt = dls->last->rec;
 388   return lex_end_of_command () == CMD_SUCCESS;
 389
 390 fail:
 391   for (i = 0; i < fx.name_cnt; i++)
 392     free (fx.name[i]);
 393   free (fx.name);
 394   return 0;
 395 }
 396
 397 /* Parses a variable specification in the form 1-10 (A) based on
 398    FX and adds specifications to the linked list with head at
 399    FIRST and tail at LAST. */
 400 static int
 401 fixed_parse_compatible (struct fixed_parsing_state *fx,
 402                         struct dls_var_spec **first, struct dls_var_spec **last)
 403 {
 404   struct fmt_spec input;
 405   int fc, lc;
 406   int width;
 407   int i;
 408
 409   /* First column. */
 410   if (!lex_force_int ())
 411     return 0;
 412   fc = lex_integer ();
 413   if (fc < 1)
 414     {
 415       msg (SE, _("Column positions for fields must be positive."));
 416       return 0;
 417     }
 418   lex_get ();
 419
 420   /* Last column. */
 421   lex_negative_to_dash ();
 422   if (lex_match ('-'))
 423     {
 424       if (!lex_force_int ())
 425         return 0;
 426       lc = lex_integer ();
 427       if (lc < 1)
 428         {
 429           msg (SE, _("Column positions for fields must be positive."));
 430           return 0;
 431         }
 432       else if (lc < fc)
 433         {
 434           msg (SE, _("The ending column for a field must be "
 435                      "greater than the starting column."));
 436           return 0;
 437         }
 438
 439       lex_get ();
 440     }
 441   else
 442     lc = fc;
 443
 444   /* Divide columns evenly. */
 445   input.w = (lc - fc + 1) / fx->name_cnt;
 446   if ((lc - fc + 1) % fx->name_cnt)
 447     {
 448       msg (SE, _("The %d columns %d-%d "
 449                  "can't be evenly divided into %d fields."),
 450            lc - fc + 1, fc, lc, fx->name_cnt);
 451       return 0;
 452     }
 453
 454   /* Format specifier. */
 455   if (lex_match ('('))
 456     {
 457       struct fmt_desc *fdp;
 458
 459       if (token == T_ID)
 460         {
 461           const char *cp;
 462
 463           input.type = parse_format_specifier_name (&cp, 0);
 464           if (input.type == -1)
 465             return 0;
 466           if (*cp)
 467             {
 468               msg (SE, _("A format specifier on this line "
 469                          "has extra characters on the end."));
 470               return 0;
 471             }
 472
 473           lex_get ();
 474           lex_match (',');
 475         }
 476       else
 477         input.type = FMT_F;
 478
 479       if (lex_is_integer ())
 480         {
 481           if (lex_integer () < 1)
 482             {
 483               msg (SE, _("The value for number of decimal places "
 484                          "must be at least 1."));
 485               return 0;
 486             }
 487
 488           input.d = lex_integer ();
 489           lex_get ();
 490         }
 491       else
 492         input.d = 0;
 493
 494       fdp = &formats[input.type];
 495       if (fdp->n_args < 2 && input.d)
 496         {
 497           msg (SE, _("Input format %s doesn't accept decimal places."),
 498                fdp->name);
 499           return 0;
 500         }
 501
 502       if (input.d > 16)
 503         input.d = 16;
 504
 505       if (!lex_force_match (')'))
 506         return 0;
 507     }
 508   else
 509     {
 510       input.type = FMT_F;
 511       input.d = 0;
 512     }
 513   if (!check_input_specifier (&input, 1))
 514     return 0;
 515
 516   /* Start column for next specification. */
 517   fx->sc = lc + 1;
 518
 519   /* Width of variables to create. */
 520   if (input.type == FMT_A || input.type == FMT_AHEX)
 521     width = input.w;
 522   else
 523     width = 0;
 524
 525   /* Create variables and var specs. */
 526   for (i = 0; i < fx->name_cnt; i++)
 527     {
 528       struct dls_var_spec *spec;
 529       struct variable *v;
 530
 531       v = dict_create_var (default_dict, fx->name[i], width);
 532       if (v != NULL)
 533         {
 534           convert_fmt_ItoO (&input, &v->print);
 535           v->write = v->print;
 536         }
 537       else
 538         {
 539           v = dict_lookup_var_assert (default_dict, fx->name[i]);
 540           if (!in_input_program ())
 541             {
 542               msg (SE, _("%s is a duplicate variable name."), fx->name[i]);
 543               return 0;
 544             }
 545           if ((width != 0) != (v->width != 0))
 546             {
 547               msg (SE, _("There is already a variable %s of a "
 548                          "different type."),
 549                    fx->name[i]);
 550               return 0;
 551             }
 552           if (width != 0 && width != v->width)
 553             {
 554               msg (SE, _("There is already a string variable %s of a "
 555                          "different width."), fx->name[i]);
 556               return 0;
 557             }
 558         }
 559
 560       spec = xmalloc (sizeof *spec);
 561       spec->input = input;
 562       spec->v = v;
 563       spec->fv = v->fv;
 564       spec->rec = fx->recno;
 565       spec->fc = fc + input.w * i;
 566       spec->lc = spec->fc + input.w - 1;
 567       append_var_spec (first, last, spec);
 568     }
 569   return 1;
 570 }
 571
 572 /* Destroy format list F and, if RECURSE is nonzero, all its
 573    sublists. */
 574 static void
 575 destroy_fmt_list (struct fmt_list *f, int recurse)
 576 {
 577   struct fmt_list *next;
 578
 579   for (; f; f = next)
 580     {
 581       next = f->next;
 582       if (recurse && f->f.type == FMT_DESCEND)
 583         destroy_fmt_list (f->down, 1);
 584       free (f);
 585     }
 586 }
 587
 588 /* Takes a hierarchically structured fmt_list F as constructed by
 589    fixed_parse_fortran(), and flattens it, adding the variable
 590    specifications to the linked list with head FIRST and tail
 591    LAST.  NAME_IDX is used to take values from the list of names
 592    in FX; it should initially point to a value of 0. */
 593 static int
 594 dump_fmt_list (struct fixed_parsing_state *fx, struct fmt_list *f,
 595                struct dls_var_spec **first, struct dls_var_spec **last,
 596                int *name_idx)
 597 {
 598   int i;
 599
 600   for (; f; f = f->next)
 601     if (f->f.type == FMT_X)
 602       fx->sc += f->count;
 603     else if (f->f.type == FMT_T)
 604       fx->sc = f->f.w;
 605     else if (f->f.type == FMT_NEWREC)
 606       {
 607         fx->recno += f->count;
 608         fx->sc = 1;
 609       }
 610     else
 611       for (i = 0; i < f->count; i++)
 612         if (f->f.type == FMT_DESCEND)
 613           {
 614             if (!dump_fmt_list (fx, f->down, first, last, name_idx))
 615               return 0;
 616           }
 617         else
 618           {
 619             struct dls_var_spec *spec;
 620             int width;
 621             struct variable *v;
 622
 623             if (formats[f->f.type].cat & FCAT_STRING)
 624               width = f->f.w;
 625             else
 626               width = 0;
 627             if (*name_idx >= fx->name_cnt)
 628               {
 629                 msg (SE, _("The number of format "
 630                            "specifications exceeds the given number of "
 631                            "variable names."));
 632                 return 0;
 633               }
 634
 635             v = dict_create_var (default_dict, fx->name[(*name_idx)++], width);
 636             if (!v)
 637               {
 638                 msg (SE, _("%s is a duplicate variable name."), fx->name[i]);
 639                 return 0;
 640               }
 641
 642             spec = xmalloc (sizeof *spec);
 643             spec->v = v;
 644             spec->input = f->f;
 645             spec->fv = v->fv;
 646             spec->rec = fx->recno;
 647             spec->fc = fx->sc;
 648             spec->lc = fx->sc + f->f.w - 1;
 649             append_var_spec (first, last, spec);
 650
 651             convert_fmt_ItoO (&spec->input, &v->print);
 652             v->write = v->print;
 653
 654             fx->sc += f->f.w;
 655           }
 656   return 1;
 657 }
 658
 659 /* Recursively parses a FORTRAN-like format specification into
 660    the linked list with head FIRST and tail TAIL.  LEVEL is the
 661    level of recursion, starting from 0.  Returns the parsed
 662    specification if successful, or a null pointer on failure.  */
 663 static struct fmt_list *
 664 fixed_parse_fortran_internal (struct fixed_parsing_state *fx,
 665                               struct dls_var_spec **first,
 666                               struct dls_var_spec **last)
 667 {
 668   struct fmt_list *head = NULL;
 669   struct fmt_list *tail = NULL;
 670
 671   lex_force_match ('(');
 672   while (token != ')')
 673     {
 674       /* New fmt_list. */
 675       struct fmt_list *new = xmalloc (sizeof *new);
 676       new->next = NULL;
 677
 678       /* Append new to list. */
 679       if (head != NULL)
 680         tail->next = new;
 681       else
 682         head = new;
 683       tail = new;
 684
 685       /* Parse count. */
 686       if (lex_is_integer ())
 687         {
 688           new->count = lex_integer ();
 689           lex_get ();
 690         }
 691       else
 692         new->count = 1;
 693
 694       /* Parse format specifier. */
 695       if (token == '(')
 696         {
 697           new->f.type = FMT_DESCEND;
 698           new->down = fixed_parse_fortran_internal (fx, first, last);
 699           if (new->down == NULL)
 700             goto fail;
 701         }
 702       else if (lex_match ('/'))
 703         new->f.type = FMT_NEWREC;
 704       else if (!parse_format_specifier (&new->f, FMTP_ALLOW_XT)
 705                || !check_input_specifier (&new->f, 1))
 706         goto fail;
 707
 708       lex_match (',');
 709     }
 710   lex_force_match (')');
 711
 712   return head;
 713
 714 fail:
 715   destroy_fmt_list (head, 0);
 716
 717   return NULL;
 718 }
 719
 720 /* Parses a FORTRAN-like format specification into the linked
 721    list with head FIRST and tail LAST.  Returns nonzero if
 722    successful. */
 723 static int
 724 fixed_parse_fortran (struct fixed_parsing_state *fx,
 725                      struct dls_var_spec **first, struct dls_var_spec **last)
 726 {
 727   struct fmt_list *list;
 728   int name_idx;
 729
 730   list = fixed_parse_fortran_internal (fx, first, last);
 731   if (list == NULL)
 732     return 0;
 733
 734   name_idx = 0;
 735   dump_fmt_list (fx, list, first, last, &name_idx);
 736   destroy_fmt_list (list, 1);
 737   if (name_idx < fx->name_cnt)
 738     {
 739       msg (SE, _("There aren't enough format specifications "
 740                  "to match the number of variable names given."));
 741       return 0;
 742     }
 743
 744   return 1;
 745 }
 746
 747 /* Displays a table giving information on fixed-format variable
 748    parsing on DATA LIST. */
 749 /* FIXME: The `Columns' column should be divided into three columns,
 750    one for the starting column, one for the dash, one for the ending
 751    column; then right-justify the starting column and left-justify the
 752    ending column. */
 753 static void
 754 dump_fixed_table (const struct dls_var_spec *specs,
 755                   const struct file_handle *fh, int rec_cnt)
 756 {
 757   const struct dls_var_spec *spec;
 758   struct tab_table *t;
 759   int i;
 760
 761   for (i = 0, spec = specs; spec; spec = spec->next)
 762     i++;
 763   t = tab_create (4, i + 1, 0);
 764   tab_columns (t, TAB_COL_DOWN, 1);
 765   tab_headers (t, 0, 0, 1, 0);
 766   tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable"));
 767   tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Record"));
 768   tab_text (t, 2, 0, TAB_CENTER | TAT_TITLE, _("Columns"));
 769   tab_text (t, 3, 0, TAB_CENTER | TAT_TITLE, _("Format"));
 770   tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 3, i);
 771   tab_hline (t, TAL_2, 0, 3, 1);
 772   tab_dim (t, tab_natural_dimensions);
 773
 774   for (i = 1, spec = specs; spec; spec = spec->next, i++)
 775     {
 776       tab_text (t, 0, i, TAB_LEFT, spec->v->name);
 777       tab_text (t, 1, i, TAT_PRINTF, "%d", spec->rec);
 778       tab_text (t, 2, i, TAT_PRINTF, "%3d-%3d",
 779                     spec->fc, spec->lc);
 780       tab_text (t, 3, i, TAB_LEFT | TAB_FIX,
 781                     fmt_to_string (&spec->input));
 782     }
 783
 784   tab_title (t, ngettext ("Reading %d record from %s.",
 785                           "Reading %d records from %s.", rec_cnt),
 786              rec_cnt, fh_get_name (fh));
 787   tab_submit (t);
 788 }
 789 \f
 790 /* Free-format parsing. */
 791
 792 /* Parses variable specifications for DATA LIST FREE and adds
 793    them to the linked list with head FIRST and tail LAST.
 794    Returns nonzero only if successful. */
 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       size_t name_cnt;
 804       int width;
 805       size_t i;
 806
 807       if (!parse_DATA_LIST_vars (&name, &name_cnt, PV_NONE))
 808         return 0;
 809
 810       if (lex_match ('('))
 811         {
 812           if (!parse_format_specifier (&input, 0)
 813               || !check_input_specifier (&input, 1)
 814               || !lex_force_match (')'))
 815             {
 816               for (i = 0; i < name_cnt; i++)
 817                 free (name[i]);
 818               free (name);
 819               return 0;
 820             }
 821           convert_fmt_ItoO (&input, &output);
 822         }
 823       else
 824         {
 825           lex_match ('*');
 826           input = make_input_format (FMT_F, 8, 0);
 827           output = *get_format ();
 828         }
 829
 830       if (input.type == FMT_A || input.type == FMT_AHEX)
 831         width = input.w;
 832       else
 833         width = 0;
 834       for (i = 0; i < name_cnt; i++)
 835         {
 836           struct dls_var_spec *spec;
 837           struct variable *v;
 838
 839           v = dict_create_var (default_dict, name[i], width);
 840
 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           spec = xmalloc (sizeof *spec);
 849           spec->input = input;
 850           spec->v = v;
 851           spec->fv = v->fv;
 852           str_copy_trunc (spec->name, sizeof spec->name, v->name);
 853           append_var_spec (first, last, spec);
 854         }
 855       for (i = 0; i < name_cnt; i++)
 856         free (name[i]);
 857       free (name);
 858     }
 859
 860   return lex_end_of_command () == CMD_SUCCESS;
 861 }
 862
 863 /* Displays a table giving information on free-format variable parsing
 864    on DATA LIST. */
 865 static void
 866 dump_free_table (const struct data_list_pgm *dls,
 867                  const struct file_handle *fh)
 868 {
 869   struct tab_table *t;
 870   int i;
 871
 872   {
 873     struct dls_var_spec *spec;
 874     for (i = 0, spec = dls->first; spec; spec = spec->next)
 875       i++;
 876   }
 877
 878   t = tab_create (2, i + 1, 0);
 879   tab_columns (t, TAB_COL_DOWN, 1);
 880   tab_headers (t, 0, 0, 1, 0);
 881   tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable"));
 882   tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Format"));
 883   tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 1, i);
 884   tab_hline (t, TAL_2, 0, 1, 1);
 885   tab_dim (t, tab_natural_dimensions);
 886
 887   {
 888     struct dls_var_spec *spec;
 889
 890     for (i = 1, spec = dls->first; spec; spec = spec->next, i++)
 891       {
 892         tab_text (t, 0, i, TAB_LEFT, spec->v->name);
 893         tab_text (t, 1, i, TAB_LEFT | TAB_FIX, fmt_to_string (&spec->input));
 894       }
 895   }
 896
 897   tab_title (t, _("Reading free-form data from %s."), fh_get_name (fh));
 898
 899   tab_submit (t);
 900 }
 901 \f
 902 /* Input procedure. */
 903
 904 /* Extracts a field from the current position in the current
 905    record.  Fields can be unquoted or quoted with single- or
 906    double-quote characters.  *FIELD is set to the field content.
 907    After parsing the field, sets the current position in the
 908    record to just past the field and any trailing delimiter.
 909    END_BLANK is used internally; it should be initialized by the
 910    caller to 0 and left alone afterward.  Returns 0 on failure or
 911    a 1-based column number indicating the beginning of the field
 912    on success. */
 913 static int
 914 cut_field (const struct data_list_pgm *dls, struct fixed_string *field,
 915            int *end_blank)
 916 {
 917   struct fixed_string line;
 918   char *cp;
 919   size_t column_start;
 920
 921   if (dfm_eof (dls->reader))
 922     return 0;
 923   if (dls->delim_cnt == 0)
 924     dfm_expand_tabs (dls->reader);
 925   dfm_get_record (dls->reader, &line);
 926
 927   cp = ls_c_str (&line);
 928   if (dls->delim_cnt == 0)
 929     {
 930       /* Skip leading whitespace. */
 931       while (cp < ls_end (&line) && isspace ((unsigned char) *cp))
 932         cp++;
 933       if (cp >= ls_end (&line))
 934         return 0;
 935
 936       /* Handle actual data, whether quoted or unquoted. */
 937       if (*cp == '\'' || *cp == '"')
 938         {
 939           int quote = *cp;
 940
 941           field->string = ++cp;
 942           while (cp < ls_end (&line) && *cp != quote)
 943             cp++;
 944           field->length = cp - field->string;
 945           if (cp < ls_end (&line))
 946             cp++;
 947           else
 948             msg (SW, _("Quoted string missing terminating `%c'."), quote);
 949         }
 950       else
 951         {
 952           field->string = cp;
 953           while (cp < ls_end (&line)
 954                  && !isspace ((unsigned char) *cp) && *cp != ',')
 955             cp++;
 956           field->length = cp - field->string;
 957         }
 958
 959       /* Skip trailing whitespace and a single comma if present. */
 960       while (cp < ls_end (&line) && isspace ((unsigned char) *cp))
 961         cp++;
 962       if (cp < ls_end (&line) && *cp == ',')
 963         cp++;
 964     }
 965   else
 966     {
 967       if (cp >= ls_end (&line))
 968         {
 969           int column = dfm_column_start (dls->reader);
 970                /* A blank line or a line that ends in \t has a
 971              trailing blank field. */
 972           if (column == 1 || (column > 1 && cp[-1] == '\t'))
 973             {
 974               if (*end_blank == 0)
 975                 {
 976                   *end_blank = 1;
 977                   field->string = ls_end (&line);
 978                   field->length = 0;
 979                   dfm_forward_record (dls->reader);
 980                   return column;
 981                 }
 982               else
 983                 {
 984                   *end_blank = 0;
 985                   return 0;
 986                 }
 987             }
 988           else
 989             return 0;
 990         }
 991       else
 992         {
 993           field->string = cp;
 994           while (cp < ls_end (&line)
 995                  && memchr (dls->delims, *cp, dls->delim_cnt) == NULL)
 996             cp++;
 997           field->length = cp - field->string;
 998           if (cp < ls_end (&line))
 999             cp++;
1000         }
1001     }
1002
1003   dfm_forward_columns (dls->reader, field->string - line.string);
1004   column_start = dfm_column_start (dls->reader);
1005
1006   dfm_forward_columns (dls->reader, cp - field->string);
1007
1008   return column_start;
1009 }
1010
1011 static bool read_from_data_list_fixed (const struct data_list_pgm *,
1012                                        struct ccase *);
1013 static bool read_from_data_list_free (const struct data_list_pgm *,
1014                                       struct ccase *);
1015 static bool read_from_data_list_list (const struct data_list_pgm *,
1016                                       struct ccase *);
1017
1018 /* Reads a case from DLS into C.
1019    Returns true if successful, false at end of file or on I/O error. */
1020 static bool
1021 read_from_data_list (const struct data_list_pgm *dls, struct ccase *c)
1022 {
1023   bool retval;
1024
1025   dfm_push (dls->reader);
1026   switch (dls->type)
1027     {
1028     case DLS_FIXED:
1029       retval = read_from_data_list_fixed (dls, c);
1030       break;
1031     case DLS_FREE:
1032       retval = read_from_data_list_free (dls, c);
1033       break;
1034     case DLS_LIST:
1035       retval = read_from_data_list_list (dls, c);
1036       break;
1037     default:
1038       abort ();
1039     }
1040   dfm_pop (dls->reader);
1041
1042   return retval;
1043 }
1044
1045 /* Reads a case from the data file into C, parsing it according
1046    to fixed-format syntax rules in DLS.
1047    Returns true if successful, false at end of file or on I/O error. */
1048 static bool
1049 read_from_data_list_fixed (const struct data_list_pgm *dls, struct ccase *c)
1050 {
1051   struct dls_var_spec *var_spec = dls->first;
1052   int i;
1053
1054   if (dfm_eof (dls->reader))
1055     return false;
1056   for (i = 1; i <= dls->rec_cnt; i++)
1057     {
1058       struct fixed_string line;
1059
1060       if (dfm_eof (dls->reader))
1061         {
1062           /* Note that this can't occur on the first record. */
1063           msg (SW, _("Partial case of %d of %d records discarded."),
1064                i - 1, dls->rec_cnt);
1065           return false;
1066         }
1067       dfm_expand_tabs (dls->reader);
1068       dfm_get_record (dls->reader, &line);
1069
1070       for (; var_spec && i == var_spec->rec; var_spec = var_spec->next)
1071         {
1072           struct data_in di;
1073
1074           data_in_finite_line (&di, ls_c_str (&line), ls_length (&line),
1075                                var_spec->fc, var_spec->lc);
1076           di.v = case_data_rw (c, var_spec->fv);
1077           di.flags = DI_IMPLIED_DECIMALS;
1078           di.f1 = var_spec->fc;
1079           di.format = var_spec->input;
1080
1081           data_in (&di);
1082         }
1083
1084       dfm_forward_record (dls->reader);
1085     }
1086
1087   return true;
1088 }
1089
1090 /* Reads a case from the data file into C, parsing it according
1091    to free-format syntax rules in DLS.
1092    Returns true if successful, false at end of file or on I/O error. */
1093 static bool
1094 read_from_data_list_free (const struct data_list_pgm *dls, struct ccase *c)
1095 {
1096   struct dls_var_spec *var_spec;
1097   int end_blank = 0;
1098
1099   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1100     {
1101       struct fixed_string field;
1102       int column;
1103
1104       /* Cut out a field and read in a new record if necessary. */
1105       for (;;)
1106         {
1107           column = cut_field (dls, &field, &end_blank);
1108           if (column != 0)
1109             break;
1110
1111           if (!dfm_eof (dls->reader))
1112             dfm_forward_record (dls->reader);
1113           if (dfm_eof (dls->reader))
1114             {
1115               if (var_spec != dls->first)
1116                 msg (SW, _("Partial case discarded.  The first variable "
1117                            "missing was %s."), var_spec->name);
1118               return false;
1119             }
1120         }
1121
1122       {
1123         struct data_in di;
1124
1125         di.s = ls_c_str (&field);
1126         di.e = ls_end (&field);
1127         di.v = case_data_rw (c, var_spec->fv);
1128         di.flags = 0;
1129         di.f1 = column;
1130         di.format = var_spec->input;
1131         data_in (&di);
1132       }
1133     }
1134   return true;
1135 }
1136
1137 /* Reads a case from the data file and parses it according to
1138    list-format syntax rules.
1139    Returns true if successful, false at end of file or on I/O error. */
1140 static bool
1141 read_from_data_list_list (const struct data_list_pgm *dls, struct ccase *c)
1142 {
1143   struct dls_var_spec *var_spec;
1144   int end_blank = 0;
1145
1146   if (dfm_eof (dls->reader))
1147     return false;
1148
1149   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1150     {
1151       struct fixed_string field;
1152       int column;
1153
1154       /* Cut out a field and check for end-of-line. */
1155       column = cut_field (dls, &field, &end_blank);
1156       if (column == 0)
1157         {
1158           if (get_undefined ())
1159             msg (SW, _("Missing value(s) for all variables from %s onward.  "
1160                        "These will be filled with the system-missing value "
1161                        "or blanks, as appropriate."),
1162                  var_spec->name);
1163           for (; var_spec; var_spec = var_spec->next)
1164             {
1165               int width = get_format_var_width (&var_spec->input);
1166               if (width == 0)
1167                 case_data_rw (c, var_spec->fv)->f = SYSMIS;
1168               else
1169                 memset (case_data_rw (c, var_spec->fv)->s, ' ', width);
1170             }
1171           break;
1172         }
1173
1174       {
1175         struct data_in di;
1176
1177         di.s = ls_c_str (&field);
1178         di.e = ls_end (&field);
1179         di.v = case_data_rw (c, var_spec->fv);
1180         di.flags = 0;
1181         di.f1 = column;
1182         di.format = var_spec->input;
1183         data_in (&di);
1184       }
1185     }
1186
1187   dfm_forward_record (dls->reader);
1188   return true;
1189 }
1190
1191 /* Destroys SPEC. */
1192 static void
1193 destroy_dls_var_spec (struct dls_var_spec *spec)
1194 {
1195   struct dls_var_spec *next;
1196
1197   while (spec != NULL)
1198     {
1199       next = spec->next;
1200       free (spec);
1201       spec = next;
1202     }
1203 }
1204
1205 /* Destroys DATA LIST transformation DLS.
1206    Returns true if successful, false if an I/O error occurred. */
1207 static bool
1208 data_list_trns_free (void *dls_)
1209 {
1210   struct data_list_pgm *dls = dls_;
1211   free (dls->delims);
1212   destroy_dls_var_spec (dls->first);
1213   dfm_close_reader (dls->reader);
1214   free (dls);
1215   return true;
1216 }
1217
1218 /* Handle DATA LIST transformation DLS, parsing data into C. */
1219 static int
1220 data_list_trns_proc (void *dls_, struct ccase *c, int case_num UNUSED)
1221 {
1222   struct data_list_pgm *dls = dls_;
1223   int retval;
1224
1225   if (read_from_data_list (dls, c))
1226     retval = TRNS_CONTINUE;
1227   else if (dfm_reader_error (dls->reader) || dfm_eof (dls->reader) > 1)
1228     {
1229       /* An I/O error, or encountering end of file for a second
1230          time, should be escalated into a more serious error. */
1231       retval = TRNS_ERROR;
1232     }
1233   else
1234     retval = TRNS_END_FILE;
1235
1236   /* If there was an END subcommand handle it. */
1237   if (dls->end != NULL)
1238     {
1239       double *end = &case_data_rw (c, dls->end->fv)->f;
1240       if (retval == TRNS_DROP_CASE)
1241         {
1242           *end = 1.0;
1243           retval = TRNS_END_FILE;
1244         }
1245       else
1246         *end = 0.0;
1247     }
1248
1249   return retval;
1250 }
1251 \f
1252 /* Reads all the records from the data file and passes them to
1253    write_case().
1254    Returns true if successful, false if an I/O error occurred. */
1255 static bool
1256 data_list_source_read (struct case_source *source,
1257                        struct ccase *c,
1258                        write_case_func *write_case, write_case_data wc_data)
1259 {
1260   struct data_list_pgm *dls = source->aux;
1261
1262   for (;;)
1263     {
1264       bool ok;
1265
1266       if (!read_from_data_list (dls, c))
1267         return !dfm_reader_error (dls->reader);
1268
1269       dfm_push (dls->reader);
1270       ok = write_case (wc_data);
1271       dfm_pop (dls->reader);
1272       if (!ok)
1273         return false;
1274     }
1275 }
1276
1277 /* Destroys the source's internal data. */
1278 static void
1279 data_list_source_destroy (struct case_source *source)
1280 {
1281   data_list_trns_free (source->aux);
1282 }
1283
1284 static const struct case_source_class data_list_source_class =
1285   {
1286     "DATA LIST",
1287     NULL,
1288     data_list_source_read,
1289     data_list_source_destroy,
1290   };