146e8a36a5b28e102558638a16b85bd18cd9cf8b
[pspp-builds.git] / src / recode.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 <assert.h>
22 #include <ctype.h>
23 #include <stdlib.h>
24 #include "alloc.h"
25 #include "approx.h"
26 #include "cases.h"
27 #include "command.h"
28 #include "error.h"
29 #include "lexer.h"
30 #include "magic.h"
31 #include "str.h"
32 #include "var.h"
33
34 #include "debug-print.h"
35 \f
36 /* Definitions. */
37
38 enum
39   {
40     RCD_END,                    /* sentinel value */
41     RCD_USER,                   /* user-missing => one */
42     RCD_SINGLE,                 /* one => one */
43     RCD_HIGH,                   /* x > a => one */
44     RCD_LOW,                    /* x < b => one */
45     RCD_RANGE,                  /* b < x < a => one */
46     RCD_ELSE,                   /* any but SYSMIS => one */
47     RCD_CONVERT                 /* "123" => 123 */
48   };
49
50 /* Describes how to recode a single value or range of values into a
51    single value.  */
52 struct coding
53   {
54     int type;                   /* RCD_* */
55     union value f1, f2;         /* Describe value or range as src.  Long
56                                    strings are stored in `c'. */
57     union value t;              /* Describes value as dest. Long strings in `c'. */
58   };
59
60 /* Describes how to recode a single variable. */
61 struct rcd_var
62   {
63     struct rcd_var *next;
64
65     unsigned flags;             /* RCD_SRC_* | RCD_DEST_* | RCD_MISC_* */
66
67     struct variable *src;       /* Source variable. */
68     struct variable *dest;      /* Destination variable. */
69     char dest_name[9];          /* Name of dest variable if we're creating it. */
70
71     int has_sysmis;             /* Do we recode for SYSMIS? */
72     union value sysmis;         /* Coding for SYSMIS (if src is numeric). */
73
74     struct coding *map;         /* Coding for other values. */
75     int nmap, mmap;             /* Length of map, max capacity of map. */
76   };
77
78 /* RECODE transformation. */
79 struct recode_trns
80   {
81     struct trns_header h;
82     struct rcd_var *codings;
83   };
84
85 /* What we're recoding from (`src'==`source'). */
86 #define RCD_SRC_ERROR           0000u   /* Bad value for src. */
87 #define RCD_SRC_NUMERIC         0001u   /* Src is numeric. */
88 #define RCD_SRC_STRING          0002u   /* Src is short string. */
89 #define RCD_SRC_MASK            0003u   /* AND mask to isolate src bits. */
90
91 /* What we're recoding to (`dest'==`destination'). */
92 #define RCD_DEST_ERROR          0000u   /* Bad value for dest. */
93 #define RCD_DEST_NUMERIC        0004u   /* Dest is numeric. */
94 #define RCD_DEST_STRING         0010u   /* Dest is short string. */
95 #define RCD_DEST_MASK           0014u   /* AND mask to isolate dest bits. */
96
97 /* Miscellaneous bits. */
98 #define RCD_MISC_CREATE         0020u   /* We create dest var (numeric only) */
99 #define RCD_MISC_DUPLICATE      0040u   /* This var_info has the same MAP
100                                            value as the previous var_info.
101                                            Prevents redundant free()ing. */
102 #define RCD_MISC_MISSING        0100u   /* Encountered MISSING or SYSMIS in
103                                            this input spec. */
104
105 static int parse_dest_spec (struct rcd_var * rcd, union value *v,
106                             size_t *max_dst_width);
107 static int parse_src_spec (struct rcd_var * rcd, int type, size_t max_src_width);
108 static int recode_trns_proc (struct trns_header *, struct ccase *);
109 static void recode_trns_free (struct trns_header *);
110 static double convert_to_double (char *, int);
111
112 #if DEBUGGING
113 static void debug_print (struct rcd_var * head);
114 #endif
115 \f
116 /* Parser. */
117
118 /* First transformation in the list.  rcd is in this list. */
119 static struct rcd_var *head;
120
121 /* Variables in the current part of the recoding. */
122 struct variable **v;
123 int nv;
124
125 /* Parses the RECODE transformation. */
126 int
127 cmd_recode (void)
128 {
129   int i;
130
131   /* Transformation that we're constructing. */
132   struct rcd_var *rcd;
133
134   /* Type of the src variables. */
135   int type;
136
137   /* Length of longest src string. */
138   size_t max_src_width;
139
140   /* Length of longest dest string. */
141   size_t max_dst_width;
142
143   /* For stepping through, constructing the linked list of
144      recodings. */
145   struct rcd_var *iter;
146
147   /* The real transformation, just a wrapper for a list of
148      rcd_var's. */
149   struct recode_trns *trns;
150
151   lex_match_id ("RECODE");
152
153   /* Parses each specification between slashes. */
154   head = rcd = xmalloc (sizeof *rcd);
155   for (;;)
156     {
157       /* Whether we've already encountered a specification for SYSMIS. */
158       int had_sysmis = 0;
159
160       /* Initialize this rcd_var to ensure proper cleanup. */
161       rcd->next = NULL;
162       rcd->map = NULL;
163       rcd->nmap = rcd->mmap = 0;
164       rcd->has_sysmis = 0;
165       rcd->sysmis.f = 0;
166
167       /* Parse variable names. */
168       if (!parse_variables (NULL, &v, &nv, PV_SAME_TYPE))
169         goto lossage;
170
171       /* Ensure all variables are same type; find length of longest
172          source variable. */
173       type = v[0]->type;
174       max_src_width = v[0]->width;
175
176       if (type == ALPHA)
177         for (i = 0; i < nv; i++)
178           if (v[i]->width > (int) max_src_width)
179             max_src_width = v[i]->width;
180
181       /* Set up flags. */
182       rcd->flags = 0;
183       if (type == NUMERIC)
184         rcd->flags |= RCD_SRC_NUMERIC;
185       else
186         rcd->flags |= RCD_SRC_STRING;
187
188       /* Parse each coding in parentheses. */
189       max_dst_width = 0;
190       if (!lex_force_match ('('))
191         goto lossage;
192       for (;;) 
193         {
194           /* Get the input value (before the `='). */
195           int mark = rcd->nmap;
196           int code = parse_src_spec (rcd, type, max_src_width);
197           if (!code)
198             goto lossage;
199
200           /* ELSE is the same as any other input spec except that it
201              precludes later sysmis specifications. */
202           if (code == 3)
203             {
204               had_sysmis = 1;
205               code = 1;
206             }
207
208           /* If keyword CONVERT was specified, there is no output
209              specification.  */
210           if (code == 1)
211             {
212               union value output;
213
214               /* Get the output value (after the `='). */
215               lex_get ();       /* Skip `='. */
216               if (!parse_dest_spec (rcd, &output, &max_dst_width))
217                 goto lossage;
218
219               /* Set the value for SYSMIS if requested and if we don't
220                  already have one. */
221               if ((rcd->flags & RCD_MISC_MISSING) && !had_sysmis)
222                 {
223                   rcd->has_sysmis = 1;
224                   if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC)
225                     rcd->sysmis.f = output.f;
226                   else
227                     rcd->sysmis.c = xstrdup (output.c);
228                   had_sysmis = 1;
229
230                   rcd->flags &= ~RCD_MISC_MISSING;
231                 }
232
233               /* Since there may be multiple input values for a single
234                  output, the output value need to propagated among all
235                  of them. */
236               if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC)
237                 for (i = mark; i < rcd->nmap; i++)
238                   rcd->map[i].t.f = output.f;
239               else
240                 {
241                   for (i = mark; i < rcd->nmap; i++)
242                     rcd->map[i].t.c = xstrdup (output.c);
243                   free (output.c);
244                 }
245             }
246           lex_get ();           /* Skip `)'. */
247           if (!lex_match ('('))
248             break;
249         }
250
251       /* Append sentinel value. */
252       rcd->map[rcd->nmap++].type = RCD_END;
253
254       /* Since multiple variables may use the same recodings, it is
255          necessary to propogate the codings to all of them. */
256       rcd->src = v[0];
257       rcd->dest = v[0];
258       rcd->dest_name[0] = 0;
259       iter = rcd;
260       for (i = 1; i < nv; i++)
261         {
262           iter = iter->next = xmalloc (sizeof *iter);
263           iter->next = NULL;
264           iter->flags = rcd->flags | RCD_MISC_DUPLICATE;
265           iter->src = v[i];
266           iter->dest = v[i];
267           iter->dest_name[0] = 0;
268           iter->has_sysmis = rcd->has_sysmis;
269           iter->sysmis = rcd->sysmis;
270           iter->map = rcd->map;
271         }
272
273       if (lex_match_id ("INTO"))
274         {
275           char **names;
276           int nnames;
277
278           int success = 0;
279
280           if (!parse_mixed_vars (&names, &nnames, PV_NONE))
281             goto lossage;
282
283           if (nnames != nv)
284             {
285               for (i = 0; i < nnames; i++)
286                 free (names[i]);
287               free (names);
288               msg (SE, _("%d variable(s) cannot be recoded into "
289                          "%d variable(s).  Specify the same number "
290                          "of variables as input and output variables."),
291                    nv, nnames);
292               goto lossage;
293             }
294
295           if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_STRING)
296             for (i = 0, iter = rcd; i < nv; i++, iter = iter->next)
297               {
298                 struct variable *v = find_variable (names[i]);
299
300                 if (!v)
301                   {
302                     msg (SE, _("There is no string variable named "
303                          "%s.  (All string variables specified "
304                          "on INTO must already exist.  Use the "
305                          "STRING command to create a string "
306                          "variable.)"), names[i]);
307                     goto INTO_fail;
308                   }
309                 if (v->type != ALPHA)
310                   {
311                     msg (SE, _("Type mismatch between input and output "
312                          "variables.  Output variable %s is not "
313                          "a string variable, but all the input "
314                          "variables are string variables."), v->name);
315                     goto INTO_fail;
316                   }
317                 if (v->width > (int) max_dst_width)
318                   max_dst_width = v->width;
319                 iter->dest = v;
320               }
321           else
322             for (i = 0, iter = rcd; i < nv; i++, iter = iter->next)
323               {
324                 struct variable *v = find_variable (names[i]);
325
326                 if (v)
327                   {
328                     if (v->type != NUMERIC)
329                       {
330                         msg (SE, _("Type mismatch after INTO: %s "
331                                    "is not a numeric variable."), v->name);
332                         goto INTO_fail;
333                       }
334                     else
335                       iter->dest = v;
336                   }
337                 else
338                   strcpy (iter->dest_name, names[i]);
339               }
340           success = 1;
341
342           /* Note that regardless of whether we succeed or fail,
343              flow-of-control comes here.  `success' is the important
344              factor.  Ah, if C had garbage collection...  */
345         INTO_fail:
346           for (i = 0; i < nnames; i++)
347             free (names[i]);
348           free (names);
349           if (!success)
350             goto lossage;
351         }
352       else
353         {
354           if (max_src_width > max_dst_width)
355             max_dst_width = max_src_width;
356
357           if ((rcd->flags & RCD_SRC_MASK) == RCD_SRC_NUMERIC
358               && (rcd->flags & RCD_DEST_MASK) != RCD_DEST_NUMERIC)
359             {
360               msg (SE, _("INTO must be used when the input values are "
361                          "numeric and output values are string."));
362               goto lossage;
363             }
364           
365           if ((rcd->flags & RCD_SRC_MASK) != RCD_SRC_NUMERIC
366               && (rcd->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC)
367             {
368               msg (SE, _("INTO must be used when the input values are "
369                          "string and output values are numeric."));
370               goto lossage;
371             }
372         }
373
374       if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_STRING)
375         {
376           struct coding *cp;
377
378           for (cp = rcd->map; cp->type != RCD_END; cp++)
379             if (cp->t.c)
380               {
381                 if (strlen (cp->t.c) < max_dst_width)
382                   {
383                     /* The NULL is only really necessary for the
384                        debugging code. */
385                     char *repl = xmalloc (max_dst_width + 1);
386                     st_pad_copy (repl, cp->t.c, max_dst_width + 1);
387                     free (cp->t.c);
388                     cp->t.c = repl;
389                   }
390                 else
391                   /* The strings are guaranteed to be in order of
392                      nondecreasing length. */
393                   break;
394               }
395           
396         }
397
398       if (!lex_match ('/'))
399         break;
400       while (rcd->next)
401         rcd = rcd->next;
402       rcd = rcd->next = xmalloc (sizeof *rcd);
403
404       free (v);
405     }
406
407   if (token != '.')
408     {
409       lex_error (_("expecting end of command"));
410       goto lossage;
411     }
412
413   for (rcd = head; rcd; rcd = rcd->next)
414     if (rcd->dest_name[0])
415       {
416         rcd->dest = create_variable (&default_dict, rcd->dest_name,
417                                      NUMERIC, 0);
418         if (!rcd->dest)
419           {
420             /* This can occur if a destname is duplicated.  We could
421                give an error at parse time but I don't care enough. */
422             rcd->dest = find_variable (rcd->dest_name);
423             assert (rcd->dest != NULL);
424           }
425         else
426           envector (rcd->dest);
427       }
428
429   trns = xmalloc (sizeof *trns);
430   trns->h.proc = recode_trns_proc;
431   trns->h.free = recode_trns_free;
432   trns->codings = head;
433   add_transformation ((struct trns_header *) trns);
434
435 #if DEBUGGING
436   debug_print (head);
437 #endif
438
439   return CMD_SUCCESS;
440
441  lossage:
442   {
443     struct recode_trns t;
444
445     t.codings = head;
446     recode_trns_free ((struct trns_header *) &t);
447     return CMD_FAILURE;
448   }
449 }
450
451 static int
452 parse_dest_spec (struct rcd_var * rcd, union value * v, size_t *max_dst_width)
453 {
454   int flags;
455
456   v->c = NULL;
457
458   if (token == T_NUM)
459     {
460       v->f = tokval;
461       lex_get ();
462       flags = RCD_DEST_NUMERIC;
463     }
464   else if (lex_match_id ("SYSMIS"))
465     {
466       v->f = SYSMIS;
467       flags = RCD_DEST_NUMERIC;
468     }
469   else if (token == T_STRING)
470     {
471       size_t max = *max_dst_width;
472       size_t toklen = ds_length (&tokstr);
473       if (toklen > max)
474         max = toklen;
475       v->c = xmalloc (max + 1);
476       st_pad_copy (v->c, ds_value (&tokstr), max + 1);
477       flags = RCD_DEST_STRING;
478       *max_dst_width = max;
479       lex_get ();
480     }
481   else if (lex_match_id ("COPY"))
482     {
483       if ((rcd->flags & RCD_SRC_MASK) == RCD_SRC_NUMERIC)
484         {
485           flags = RCD_DEST_NUMERIC;
486           v->f = -SYSMIS;
487         }
488       else
489         {
490           flags = RCD_DEST_STRING;
491           v->c = NULL;
492         }
493     }
494
495   if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_ERROR)
496     rcd->flags |= flags;
497 #if 0
498   else if (((rcd->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC
499             && flags != RCD_DEST_NUMERIC)
500            || ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_STRING
501                && flags != RCD_DEST_STRING))
502 #endif
503     else if ((rcd->flags & RCD_DEST_MASK) ^ flags)
504       {
505         msg (SE, _("Inconsistent output types.  The output values "
506                    "must be all numeric or all string."));
507         return 0;
508       }
509
510   return 1;
511 }
512
513 /* Reads a set of source specifications and returns one of the
514    following values: 0 on failure; 1 for normal success; 2 for success
515    but with CONVERT as the keyword; 3 for success but with ELSE as the
516    keyword. */
517 static int
518 parse_src_spec (struct rcd_var * rcd, int type, size_t max_src_width)
519 {
520   struct coding *c;
521
522   for (;;)
523     {
524       if (rcd->nmap >= rcd->mmap - 1)
525         {
526           rcd->mmap += 16;
527           rcd->map = xrealloc (rcd->map, rcd->mmap * sizeof *rcd->map);
528         }
529
530       c = &rcd->map[rcd->nmap];
531       c->f1.c = c->f2.c = NULL;
532       if (lex_match_id ("ELSE"))
533         {
534           c->type = RCD_ELSE;
535           rcd->nmap++;
536           return 3;
537         }
538       else if (type == NUMERIC)
539         {
540           if (token == T_ID)
541             {
542               if (lex_match_id ("LO") || lex_match_id ("LOWEST"))
543                 {
544                   if (!lex_force_match_id ("THRU"))
545                     return 0;
546                   if (lex_match_id ("HI") || lex_match_id ("HIGHEST"))
547                     c->type = RCD_ELSE;
548                   else if (token == T_NUM)
549                     {
550                       c->type = RCD_LOW;
551                       c->f1.f = tokval;
552                       lex_get ();
553                     }
554                   else
555                     {
556                       lex_error (_("following LO THRU"));
557                       return 0;
558                     }
559                 }
560               else if (lex_match_id ("MISSING"))
561                 {
562                   c->type = RCD_USER;
563                   rcd->flags |= RCD_MISC_MISSING;
564                 }
565               else if (lex_match_id ("SYSMIS"))
566                 {
567                   c->type = RCD_END;
568                   rcd->flags |= RCD_MISC_MISSING;
569                 }
570               else
571                 {
572                   lex_error (_("in source value"));
573                   return 0;
574                 }
575             }
576           else if (token == T_NUM)
577             {
578               c->f1.f = tokval;
579               lex_get ();
580               if (lex_match_id ("THRU"))
581                 {
582                   if (lex_match_id ("HI") || lex_match_id ("HIGHEST"))
583                     c->type = RCD_HIGH;
584                   else if (token == T_NUM)
585                     {
586                       c->type = RCD_RANGE;
587                       c->f2.f = tokval;
588                       lex_get ();
589                     }
590                   else
591                     {
592                       lex_error (NULL);
593                       return 0;
594                     }
595                 }
596               else
597                 c->type = RCD_SINGLE;
598             }
599           else
600             {
601               lex_error (_("in source value"));
602               return 0;
603             }
604         }
605       else
606         {
607           assert (type == ALPHA);
608           if (lex_match_id ("CONVERT"))
609             {
610               if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_ERROR)
611                 rcd->flags |= RCD_DEST_NUMERIC;
612               else if ((rcd->flags & RCD_DEST_MASK) != RCD_DEST_NUMERIC)
613                 {
614                   msg (SE, _("Keyword CONVERT may only be used with "
615                              "string input values and numeric output "
616                              "values."));
617                   return 0;
618                 }
619
620               c->type = RCD_CONVERT;
621               rcd->nmap++;
622               return 2;
623             }
624           else
625             {
626               /* Only the debugging code needs the NULLs at the ends
627                  of the strings.  However, changing code behavior more
628                  than necessary based on the DEBUGGING `#define' is just
629                  *inviting* bugs. */
630               c->type = RCD_SINGLE;
631               if (!lex_force_string ())
632                 return 0;
633               c->f1.c = xmalloc (max_src_width + 1);
634               st_pad_copy (c->f1.c, ds_value (&tokstr), max_src_width + 1);
635               lex_get ();
636             }
637         }
638
639       if (c->type != RCD_END)
640         rcd->nmap++;
641
642       lex_match (',');
643       if (token == '=')
644         break;
645     }
646   return 1;
647 }
648 \f
649 /* Data transformation. */
650
651 static void
652 recode_trns_free (struct trns_header * t)
653 {
654   int i;
655   struct rcd_var *head, *next;
656
657   head = ((struct recode_trns *) t)->codings;
658   while (head)
659     {
660       if (head->map && !(head->flags & RCD_MISC_DUPLICATE))
661         {
662           if (head->flags & RCD_SRC_STRING)
663             for (i = 0; i < head->nmap; i++)
664               switch (head->map[i].type)
665                 {
666                 case RCD_RANGE:
667                   free (head->map[i].f2.c);
668                   /* fall through */
669                 case RCD_USER:
670                 case RCD_SINGLE:
671                 case RCD_HIGH:
672                 case RCD_LOW:
673                   free (head->map[i].f1.c);
674                   break;
675                 case RCD_END:
676                 case RCD_ELSE:
677                 case RCD_CONVERT:
678                   break;
679                 default:
680                   assert (0);
681                 }
682           if (head->flags & RCD_DEST_STRING)
683             for (i = 0; i < head->nmap; i++)
684               if (head->map[i].type != RCD_CONVERT && head->map[i].type != RCD_END)
685                 free (head->map[i].t.c);
686           free (head->map);
687         }
688       next = head->next;
689       free (head);
690       head = next;
691     }
692 }
693
694 static inline struct coding *
695 find_src_numeric (struct rcd_var * v, struct ccase * c)
696 {
697   double cmp = c->data[v->src->fv].f;
698   struct coding *cp;
699
700   if (cmp == SYSMIS)
701     {
702       if (v->sysmis.f != -SYSMIS)
703         {
704           if ((v->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC)
705             c->data[v->dest->fv].f = v->sysmis.f;
706           else
707             memcpy (c->data[v->dest->fv].s, v->sysmis.c,
708                     v->dest->width);
709         }
710       return NULL;
711     }
712
713   for (cp = v->map;; cp++)
714     switch (cp->type)
715       {
716       case RCD_END:
717         return NULL;
718       case RCD_USER:
719         if (is_num_user_missing (cmp, v->src))
720           return cp;
721         break;
722       case RCD_SINGLE:
723         if (approx_eq (cmp, cp->f1.f))
724           return cp;
725         break;
726       case RCD_HIGH:
727         if (approx_ge (cmp, cp->f1.f))
728           return cp;
729         break;
730       case RCD_LOW:
731         if (approx_le (cmp, cp->f1.f))
732           return cp;
733         break;
734       case RCD_RANGE:
735         if (approx_in_range (cmp, cp->f1.f, cp->f2.f))
736           return cp;
737         break;
738       case RCD_ELSE:
739         return cp;
740       default:
741         assert (0);
742       }
743 }
744
745 static inline struct coding *
746 find_src_string (struct rcd_var * v, struct ccase * c)
747 {
748   char *cmp = c->data[v->src->fv].s;
749   int w = v->src->width;
750   struct coding *cp;
751
752   for (cp = v->map;; cp++)
753     switch (cp->type)
754       {
755       case RCD_END:
756         return NULL;
757       case RCD_SINGLE:
758         if (!memcmp (cp->f1.c, cmp, w))
759           return cp;
760         break;
761       case RCD_ELSE:
762         return cp;
763       case RCD_CONVERT:
764         {
765           double f = convert_to_double (cmp, w);
766           if (f != -SYSMIS)
767             {
768               c->data[v->dest->fv].f = f;
769               return NULL;
770             }
771           break;
772         }
773       default:
774         assert (0);
775       }
776 }
777
778 static int
779 recode_trns_proc (struct trns_header * t, struct ccase * c)
780 {
781   struct rcd_var *v;
782   struct coding *cp;
783
784   for (v = ((struct recode_trns *) t)->codings; v; v = v->next)
785     {
786       switch (v->flags & RCD_SRC_MASK)
787         {
788         case RCD_SRC_NUMERIC:
789           cp = find_src_numeric (v, c);
790           break;
791         case RCD_SRC_STRING:
792           cp = find_src_string (v, c);
793           break;
794         }
795       if (!cp)
796         continue;
797
798       /* A matching input value was found. */
799       if ((v->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC)
800         {
801           double val = cp->t.f;
802           if (val == -SYSMIS)
803             c->data[v->dest->fv].f = c->data[v->src->fv].f;
804           else
805             c->data[v->dest->fv].f = val;
806         }
807       else
808         {
809           char *val = cp->t.c;
810           if (val == NULL)
811             st_bare_pad_len_copy (c->data[v->dest->fv].s,
812                                   c->data[v->src->fv].c,
813                                   v->dest->width, v->src->width);
814           else
815             memcpy (c->data[v->dest->fv].s, cp->t.c, v->dest->width);
816         }
817     }
818
819   return -1;
820 }
821 \f
822 /* Debug output. */
823
824 #if DEBUGGING
825 static void
826 dump_dest (struct rcd_var * v, union value * c)
827 {
828   if ((v->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC)
829     if (c->f == SYSMIS)
830       printf ("=SYSMIS");
831     else if (c->f == -SYSMIS)
832       printf ("=COPY");
833     else
834       printf ("=%g", c->f);
835   else if (c->c)
836     printf ("=\"%s\"", c->c);
837   else
838     printf ("=COPY");
839 }
840
841 static void
842 debug_print (struct rcd_var * head)
843 {
844   struct rcd_var *iter, *start;
845   struct coding *c;
846
847   printf ("RECODE\n");
848   for (iter = head; iter; iter = iter->next)
849     {
850       start = iter;
851       printf ("  %s%s", iter == head ? "" : "/", iter->src->name);
852       while (iter->next && (iter->next->flags & RCD_MISC_DUPLICATE))
853         {
854           iter = iter->next;
855           printf (" %s", iter->src->name);
856         }
857       if (iter->has_sysmis)
858         {
859           printf ("(SYSMIS");
860           dump_dest (iter, &iter->sysmis);
861           printf (")");
862         }
863       for (c = iter->map; c->type != RCD_END; c++)
864         {
865           printf ("(");
866           if ((iter->flags & RCD_SRC_MASK) == RCD_SRC_NUMERIC)
867             switch (c->type)
868               {
869               case RCD_END:
870                 printf (_("!!END!!"));
871                 break;
872               case RCD_USER:
873                 printf ("MISSING");
874                 break;
875               case RCD_SINGLE:
876                 printf ("%g", c->f1.f);
877                 break;
878               case RCD_HIGH:
879                 printf ("%g THRU HIGH", c->f1.f);
880                 break;
881               case RCD_LOW:
882                 printf ("LOW THRU %g", c->f1.f);
883                 break;
884               case RCD_RANGE:
885                 printf ("%g THRU %g", c->f1.f, c->f2.f);
886                 break;
887               case RCD_ELSE:
888                 printf ("ELSE");
889                 break;
890               default:
891                 printf (_("!!ERROR!!"));
892                 break;
893               }
894           else
895             switch (c->type)
896               {
897               case RCD_SINGLE:
898                 printf ("\"%s\"", c->f1.c);
899                 break;
900               case RCD_ELSE:
901                 printf ("ELSE");
902                 break;
903               case RCD_CONVERT:
904                 printf ("CONVERT");
905                 break;
906               default:
907                 printf (_("!!ERROR!!"));
908                 break;
909               }
910           if (c->type != RCD_CONVERT)
911             dump_dest (iter, &c->t);
912           printf (")");
913         }
914       printf ("\n    INTO");
915       for (;;)
916         {
917           printf (" %s",
918                 start->dest_name[0] ? start->dest_name : start->dest->name);
919           if (start == iter)
920             break;
921           start = start->next;
922         }
923       printf ("\n");
924     }
925 }
926 #endif
927
928 /* Convert NPTR to a `long int' in base 10.  Returns the long int on
929    success, NOT_LONG on failure.  On success stores a pointer to the
930    first character after the number into *ENDPTR.  From the GNU C
931    library. */
932 long int
933 string_to_long (char *nptr, int width, char **endptr)
934 {
935   int negative;
936   register unsigned long int cutoff;
937   register unsigned int cutlim;
938   register unsigned long int i;
939   register char *s;
940   register unsigned char c;
941   const char *save;
942
943   s = nptr;
944
945   /* Check for a sign.  */
946   if (*s == '-')
947     {
948       negative = 1;
949       ++s;
950     }
951   else if (*s == '+')
952     {
953       negative = 0;
954       ++s;
955     }
956   else
957     negative = 0;
958   if (s >= nptr + width)
959     return NOT_LONG;
960
961   /* Save the pointer so we can check later if anything happened.  */
962   save = s;
963
964   cutoff = ULONG_MAX / 10ul;
965   cutlim = ULONG_MAX % 10ul;
966
967   i = 0;
968   for (c = *s;;)
969     {
970       if (isdigit ((unsigned char) c))
971         c -= '0';
972       else
973         break;
974       /* Check for overflow.  */
975       if (i > cutoff || (i == cutoff && c > cutlim))
976         return NOT_LONG;
977       else
978         i = i * 10ul + c;
979
980       s++;
981       if (s >= nptr + width)
982         break;
983       c = *s;
984     }
985
986   /* Check if anything actually happened.  */
987   if (s == save)
988     return NOT_LONG;
989
990   /* Check for a value that is within the range of `unsigned long
991      int', but outside the range of `long int'.  We limit LONG_MIN and
992      LONG_MAX by one point because we know that NOT_LONG is out there
993      somewhere. */
994   if (i > (negative
995            ? -((unsigned long int) LONG_MIN) - 1
996            : ((unsigned long int) LONG_MAX) - 1))
997     return NOT_LONG;
998
999   *endptr = s;
1000
1001   /* Return the result of the appropriate sign.  */
1002   return (negative ? -i : i);
1003 }
1004
1005 /* Converts S to a double according to format Fx.0.  Returns the value
1006    found, or -SYSMIS if there was no valid number in s.  WIDTH is the
1007    length of string S.  From the GNU C library. */
1008 static double
1009 convert_to_double (char *s, int width)
1010 {
1011   register const char *end = &s[width];
1012
1013   short int sign;
1014
1015   /* The number so far.  */
1016   double num;
1017
1018   int got_dot;                  /* Found a decimal point.  */
1019   int got_digit;                /* Count of digits.  */
1020
1021   /* The exponent of the number.  */
1022   long int exponent;
1023
1024   /* Eat whitespace.  */
1025   while (s < end && isspace ((unsigned char) *s))
1026     ++s;
1027   if (s >= end)
1028     return SYSMIS;
1029
1030   /* Get the sign.  */
1031   sign = *s == '-' ? -1 : 1;
1032   if (*s == '-' || *s == '+')
1033     {
1034       ++s;
1035       if (s >= end)
1036         return -SYSMIS;
1037     }
1038
1039   num = 0.0;
1040   got_dot = 0;
1041   got_digit = 0;
1042   exponent = 0;
1043   for (; s < end; ++s)
1044     {
1045       if (isdigit ((unsigned char) *s))
1046         {
1047           got_digit++;
1048
1049           /* Make sure that multiplication by 10 will not overflow.  */
1050           if (num > DBL_MAX * 0.1)
1051             /* The value of the digit doesn't matter, since we have already
1052                gotten as many digits as can be represented in a `double'.
1053                This doesn't necessarily mean the result will overflow.
1054                The exponent may reduce it to within range.
1055
1056                We just need to record that there was another
1057                digit so that we can multiply by 10 later.  */
1058             ++exponent;
1059           else
1060             num = (num * 10.0) + (*s - '0');
1061
1062           /* Keep track of the number of digits after the decimal point.
1063              If we just divided by 10 here, we would lose precision.  */
1064           if (got_dot)
1065             --exponent;
1066         }
1067       else if (!got_dot && *s == '.')
1068         /* Record that we have found the decimal point.  */
1069         got_dot = 1;
1070       else
1071         break;
1072     }
1073
1074   if (!got_digit)
1075     return -SYSMIS;
1076
1077   if (s < end && (tolower ((unsigned char) (*s)) == 'e'
1078                   || tolower ((unsigned char) (*s)) == 'd'))
1079     {
1080       /* Get the exponent specified after the `e' or `E'.  */
1081       long int exp;
1082
1083       s++;
1084       if (s >= end)
1085         return -SYSMIS;
1086
1087       exp = string_to_long (s, end - s, &s);
1088       if (exp == NOT_LONG || end == s)
1089         return -SYSMIS;
1090       exponent += exp;
1091     }
1092
1093   while (s < end && isspace ((unsigned char) *s))
1094     s++;
1095   if (s < end)
1096     return -SYSMIS;
1097
1098   if (num == 0.0)
1099     return 0.0;
1100
1101   /* Multiply NUM by 10 to the EXPONENT power,
1102      checking for overflow and underflow.  */
1103
1104   if (exponent < 0)
1105     {
1106       if (-exponent + got_digit > -(DBL_MIN_10_EXP) + 5
1107           || num < DBL_MIN * pow (10.0, (double) -exponent))
1108         return -SYSMIS;
1109       num *= pow (10.0, (double) exponent);
1110     }
1111   else if (exponent > 0)
1112     {
1113       if (num > DBL_MAX * pow (10.0, (double) -exponent))
1114         return -SYSMIS;
1115       num *= pow (10.0, (double) exponent);
1116     }
1117
1118   return sign > 0 ? num : -num;
1119 }