home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / octave-1.1.1p1-src.tgz / tar.out / fsf / octave / src / load-save.cc < prev    next >
C/C++ Source or Header  |  1996-09-28  |  63KB  |  3,062 lines
  1. // load-save.cc                                              -*- C++ -*-
  2. /*
  3.  
  4. Copyright (C) 1992, 1993, 1994, 1995 John W. Eaton
  5.  
  6. This file is part of Octave.
  7.  
  8. Octave is free software; you can redistribute it and/or modify it
  9. under the terms of the GNU General Public License as published by the
  10. Free Software Foundation; either version 2, or (at your option) any
  11. later version.
  12.  
  13. Octave is distributed in the hope that it will be useful, but WITHOUT
  14. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16. for more details.
  17.  
  18. You should have received a copy of the GNU General Public License
  19. along with Octave; see the file COPYING.  If not, write to the Free
  20. Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. */
  23.  
  24. #ifdef HAVE_CONFIG_H
  25. #include "config.h"
  26. #endif
  27.  
  28. #include <float.h>
  29. #include <limits.h>
  30. #include <string.h>
  31. #include <iostream.h>
  32. #include <fstream.h>
  33. #include <strstream.h>
  34. #include <ctype.h>
  35.  
  36. #include "tree-base.h"
  37. #include "tree-expr.h"
  38. #include "tree-const.h"
  39. #include "user-prefs.h"
  40. #include "unwind-prot.h"
  41. #include "load-save.h"
  42. #include "symtab.h"
  43. #include "pager.h"
  44. #include "error.h"
  45. #include "gripes.h"
  46. #include "defun.h"
  47. #include "utils.h"
  48. #include "help.h"
  49.  
  50. extern "C"
  51. {
  52. #include <readline/tilde.h>
  53.  
  54. #include "fnmatch.h"
  55. }
  56.  
  57. #if CHAR_BIT != 8
  58. LOSE! LOSE!
  59. #endif
  60.  
  61. #if SIZEOF_SHORT == 2
  62. #define TWO_BYTE_INT short
  63. #elif SIZEOF_INT == 2
  64. #define TWO_BYTE_INT int
  65. #else
  66. LOSE! LOSE!
  67. #endif
  68.  
  69. #if SIZEOF_INT == 4
  70. #define FOUR_BYTE_INT int
  71. #elif SIZEOF_LONG == 4
  72. #define FOUR_BYTE_INT long
  73. #else
  74. LOSE! LOSE!
  75. #endif
  76.  
  77. // Used when converting Inf to something that gnuplot can read.
  78.  
  79. #ifndef OCT_RBV
  80. #define OCT_RBV DBL_MAX / 100.0
  81. #endif
  82.  
  83. enum load_save_format
  84.   {
  85.     LS_ASCII,
  86.     LS_BINARY,
  87.     LS_MAT_BINARY,
  88.     LS_UNKNOWN,
  89.   };
  90.  
  91. enum floating_point_format
  92.   {
  93.     LS_IEEE_LITTLE,
  94.     LS_IEEE_BIG,
  95.     LS_VAX_D,
  96.     LS_VAX_G,
  97.     LS_CRAY,
  98.     LS_UNKNOWN_FLT_FMT,
  99.   };
  100.  
  101. // Not all of the following are currently used.
  102.  
  103. enum save_type
  104.   {
  105.     LS_U_CHAR,
  106.     LS_U_SHORT,
  107.     LS_U_INT,
  108.     LS_CHAR,
  109.     LS_SHORT,
  110.     LS_INT,
  111.     LS_FLOAT,
  112.     LS_DOUBLE,
  113.   };
  114.  
  115. #if defined (IEEE_LITTLE_ENDIAN)
  116. #define NATIVE_FLOAT_FORMAT LS_IEEE_LITTLE
  117. #elif defined (IEEE_BIG_ENDIAN)
  118. #define NATIVE_FLOAT_FORMAT LS_IEEE_BIG
  119. #elif defined (VAX_D_FLOAT)
  120. #define NATIVE_FLOAT_FORMAT LS_VAX_D
  121. #elif defined (VAX_G_FLOAT)
  122. #define NATIVE_FLOAT_FORMAT LS_VAX_G
  123. #else
  124. LOSE! LOSE!
  125. #endif
  126.  
  127. #define swap_1_bytes(x,y)
  128.  
  129. #define LS_DO_READ(TYPE,swap,data,size,len,stream) \
  130.   do \
  131.     { \
  132.       volatile TYPE *ptr = (TYPE *) data; \
  133.       stream.read ((TYPE *) ptr, size * len); \
  134.       if (swap) \
  135.         swap_ ## size ## _bytes ((char *) ptr, len); \
  136.       TYPE tmp = ptr[0]; \
  137.       for (int i = len - 1; i > 0; i--) \
  138.         data[i] = ptr[i]; \
  139.       data[0] = tmp; \
  140.     } \
  141.   while (0)
  142.  
  143. // Have to use copy here to avoid writing over data accessed via
  144. // Matrix::data().
  145.  
  146. #define LS_DO_WRITE(TYPE,data,size,len,stream) \
  147.   do \
  148.     { \
  149.       char tmp_type = (char) type; \
  150.       stream.write (&tmp_type, 1); \
  151.       TYPE *ptr = new TYPE [len]; \
  152.       for (int i = 0; i < len; i++) \
  153.         ptr[i] = (TYPE) data[i]; \
  154.       stream.write ((TYPE *) ptr, size * len); \
  155.       delete [] ptr ; \
  156.     } \
  157.   while (0)
  158.  
  159. // Loading variables from files.
  160.  
  161. // But first, some data conversion routines.
  162.  
  163. // Currently, we only handle conversions for the IEEE types.  To fix
  164. // that, make more of the following routines work.
  165.  
  166. #define LS_SWAP_BYTES(i,j) \
  167.   tmp = t[i]; \
  168.   t[i] = t[j]; \
  169.   t[j] = tmp; \
  170.  
  171. static inline void
  172. swap_2_bytes (char *t)
  173. {
  174.   char tmp;
  175.   LS_SWAP_BYTES (0, 1);
  176. }
  177.  
  178. static inline void
  179. swap_4_bytes (char *t)
  180. {
  181.   char tmp;
  182.   LS_SWAP_BYTES (0, 3);
  183.   LS_SWAP_BYTES (1, 2);
  184. }
  185.  
  186. static inline void
  187. swap_8_bytes (char *t)
  188. {
  189.   char tmp;
  190.   LS_SWAP_BYTES (0, 7);
  191.   LS_SWAP_BYTES (1, 6);
  192.   LS_SWAP_BYTES (2, 5);
  193.   LS_SWAP_BYTES (3, 4);
  194. }
  195.  
  196. static inline void
  197. swap_2_bytes (char *t, int len)
  198. {
  199.   char *ptr = t;
  200.   for (int i = 0; i < len; i++)
  201.     {
  202.       swap_2_bytes (ptr);
  203.       ptr += 2;
  204.     }
  205. }
  206.  
  207. static inline void
  208. swap_4_bytes (char *t, int len)
  209. {
  210.   char *ptr = t;
  211.   for (int i = 0; i < len; i++)
  212.     {
  213.       swap_4_bytes (ptr);
  214.       ptr += 4;
  215.     }
  216. }
  217.  
  218. static inline void
  219. swap_8_bytes (char *t, int len)
  220. {
  221.   char *ptr = t;
  222.   for (int i = 0; i < len; i++)
  223.     {
  224.       swap_8_bytes (ptr);
  225.       ptr += 8;
  226.     }
  227. }
  228.  
  229. // XXX FIXME XXX -- assumes sizeof (Complex) == 8
  230. // XXX FIXME XXX -- assumes sizeof (double) == 8
  231. // XXX FIXME XXX -- assumes sizeof (float) == 4
  232.  
  233. #if defined (IEEE_LITTLE_ENDIAN)
  234.  
  235. static void
  236. IEEE_big_double_to_IEEE_little_double (double *d, int len)
  237. {
  238.   swap_8_bytes ((char *) d, len);
  239. }
  240.  
  241. static void
  242. VAX_D_double_to_IEEE_little_double (double *d, int len)
  243. {
  244.   gripe_data_conversion ("VAX D float", "IEEE little endian format");
  245. }
  246.  
  247. static void
  248. VAX_G_double_to_IEEE_little_double (double *d, int len)
  249. {
  250.   gripe_data_conversion ("VAX G float", "IEEE little endian format");
  251. }
  252.  
  253. static void
  254. Cray_to_IEEE_little_double (double *d, int len)
  255. {
  256.   gripe_data_conversion ("Cray", "IEEE little endian format");
  257. }
  258.  
  259. static void
  260. IEEE_big_float_to_IEEE_little_float (float *d, int len)
  261. {
  262.   swap_4_bytes ((char *) d, len);
  263. }
  264.  
  265. static void
  266. VAX_D_float_to_IEEE_little_float (float *d, int len)
  267. {
  268.   gripe_data_conversion ("VAX D float", "IEEE little endian format");
  269. }
  270.  
  271. static void
  272. VAX_G_float_to_IEEE_little_float (float *d, int len)
  273. {
  274.   gripe_data_conversion ("VAX G float", "IEEE little endian format");
  275. }
  276.  
  277. static void
  278. Cray_to_IEEE_little_float (float *d, int len)
  279. {
  280.   gripe_data_conversion ("Cray", "IEEE little endian format");
  281. }
  282.  
  283. #elif defined (IEEE_BIG_ENDIAN)
  284.  
  285. static void
  286. IEEE_little_double_to_IEEE_big_double (double *d, int len)
  287. {
  288.   swap_8_bytes ((char *) d, len);
  289. }
  290.  
  291. static void
  292. VAX_D_double_to_IEEE_big_double (double *d, int len)
  293. {
  294.   gripe_data_conversion ("VAX D float", "IEEE big endian format");
  295. }
  296.  
  297. static void
  298. VAX_G_double_to_IEEE_big_double (double *d, int len)
  299. {
  300.   gripe_data_conversion ("VAX G float", "IEEE big endian format");
  301. }
  302.  
  303. static void
  304. Cray_to_IEEE_big_double (double *d, int len)
  305. {
  306.   gripe_data_conversion ("Cray", "IEEE big endian format");
  307. }
  308.  
  309. static void
  310. IEEE_little_float_to_IEEE_big_float (float *d, int len)
  311. {
  312.   swap_4_bytes ((char *) d, len);
  313. }
  314.  
  315. static void
  316. VAX_D_float_to_IEEE_big_float (float *d, int len)
  317. {
  318.   gripe_data_conversion ("VAX D float", "IEEE big endian format");
  319. }
  320.  
  321. static void
  322. VAX_G_float_to_IEEE_big_float (float *d, int len)
  323. {
  324.   gripe_data_conversion ("VAX G float", "IEEE big endian format");
  325. }
  326.  
  327. static void
  328. Cray_to_IEEE_big_float (float *d, int len)
  329. {
  330.   gripe_data_conversion ("Cray", "IEEE big endian format");
  331. }
  332.  
  333. #elif defined (VAX_D_FLOAT)
  334.  
  335. static void
  336. IEEE_little_double_to_VAX_D_double (double *d, int len)
  337. {
  338.   gripe_data_conversion ("IEEE little endian", "VAX D");
  339. }
  340.  
  341. static void
  342. IEEE_big_double_to_VAX_D_double (double *d, int len)
  343. {
  344.   gripe_data_conversion ("IEEE big endian", "VAX D");
  345. }
  346.  
  347. static void
  348. VAX_G_double_to_VAX_D_double (double *d, int len)
  349. {
  350.   gripe_data_conversion ("VAX G float", "VAX D");
  351. }
  352.  
  353. static void
  354. Cray_to_VAX_D_double (double *d, int len)
  355. {
  356.   gripe_data_conversion ("Cray", "VAX D");
  357. }
  358.  
  359. static void
  360. IEEE_little_float_to_VAX_D_float (float *d, int len)
  361. {
  362.   gripe_data_conversion ("IEEE little endian", "VAX D");
  363. }
  364.  
  365. static void
  366. IEEE_big_float_to_VAX_D_float (float *d, int len)
  367. {
  368.   gripe_data_conversion ("IEEE big endian", "VAX D");
  369. }
  370.  
  371. static void
  372. VAX_G_float_to_VAX_D_float (float *d, int len)
  373. {
  374.   gripe_data_conversion ("VAX G float", "VAX D");
  375. }
  376.  
  377. static void
  378. Cray_to_VAX_D_float (float *d, int len)
  379. {
  380.   gripe_data_conversion ("Cray", "VAX D");
  381. }
  382.  
  383. #elif defined (VAX_G_FLOAT)
  384.  
  385. static void
  386. IEEE_little_double_to_VAX_G_double (double *d, int len)
  387. {
  388.   gripe_data_conversion ("IEEE little endian", "VAX G");
  389. }
  390.  
  391. static void
  392. IEEE_big_double_to_VAX_G_double (double *d, int len)
  393. {
  394.   gripe_data_conversion ("IEEE big endian", "VAX G");
  395. }
  396.  
  397. static void
  398. VAX_D_double_to_VAX_G_double (double *d, int len)
  399. {
  400.   gripe_data_conversion ("VAX D float", "VAX G");
  401. }
  402.  
  403. static void
  404. Cray_to_VAX_G_double (double *d, int len)
  405. {
  406.   gripe_data_conversion ("VAX G float", "VAX G");
  407. }
  408.  
  409. static void
  410. IEEE_little_float_to_VAX_G_float (float *d, int len)
  411. {
  412.   gripe_data_conversion ("IEEE little endian", "VAX G");
  413. }
  414.  
  415. static void
  416. IEEE_big_float_to_VAX_G_float (float *d, int len)
  417. {
  418.   gripe_data_conversion ("IEEE big endian", "VAX G");
  419. }
  420.  
  421. static void
  422. VAX_D_float_to_VAX_G_float (float *d, int len)
  423. {
  424.   gripe_data_conversion ("VAX D float", "VAX G");
  425. }
  426.  
  427. static void
  428. Cray_to_VAX_G_float (float *d, int len)
  429. {
  430.   gripe_data_conversion ("VAX G float", "VAX G");
  431. }
  432.  
  433. #endif
  434.  
  435. static void
  436. do_double_format_conversion (double *data, int len,
  437.                  floating_point_format fmt)
  438. {
  439.   switch (fmt)
  440.     {
  441. #if defined (IEEE_LITTLE_ENDIAN)
  442.  
  443.     case LS_IEEE_LITTLE:
  444.       break;
  445.  
  446.     case LS_IEEE_BIG:
  447.       IEEE_big_double_to_IEEE_little_double (data, len);
  448.       break;
  449.  
  450.     case LS_VAX_D:
  451.       VAX_D_double_to_IEEE_little_double (data, len);
  452.       break;
  453.  
  454.     case LS_VAX_G:
  455.       VAX_G_double_to_IEEE_little_double (data, len);
  456.       break;
  457.  
  458.     case LS_CRAY:
  459.       Cray_to_IEEE_little_double (data, len);
  460.       break;
  461.  
  462. #elif defined (IEEE_BIG_ENDIAN)
  463.  
  464.     case LS_IEEE_LITTLE:
  465.       IEEE_little_double_to_IEEE_big_double (data, len);
  466.       break;
  467.  
  468.     case LS_IEEE_BIG:
  469.       break;
  470.  
  471.     case LS_VAX_D:
  472.       VAX_D_double_to_IEEE_big_double (data, len);
  473.       break;
  474.  
  475.     case LS_VAX_G:
  476.       VAX_G_double_to_IEEE_big_double (data, len);
  477.       break;
  478.  
  479.     case LS_CRAY:
  480.       Cray_to_IEEE_big_double (data, len);
  481.       break;
  482.  
  483. #elif defined (VAX_D_FLOAT)
  484.  
  485.     case LS_IEEE_LITTLE:
  486.       IEEE_little_double_to_VAX_D_double (data, len);
  487.       break;
  488.  
  489.     case LS_IEEE_BIG:
  490.       IEEE_big_double_to_VAX_D_double (data, len);
  491.       break;
  492.  
  493.     case LS_VAX_D:
  494.       break;
  495.  
  496.     case LS_VAX_G:
  497.       VAX_G_double_to_VAX_D_double (data, len);
  498.       break;
  499.  
  500.     case LS_CRAY:
  501.       Cray_to_VAX_D_double (data, len);
  502.       break;
  503.  
  504. #elif defined (VAX_G_FLOAT)
  505.  
  506.     case LS_IEEE_LITTLE:
  507.       IEEE_little_double_to_VAX_G_double (data, len);
  508.       break;
  509.  
  510.     case LS_IEEE_BIG:
  511.       IEEE_big_double_to_VAX_G_double (data, len);
  512.       break;
  513.  
  514.     case LS_VAX_D:
  515.       VAX_D_double_to_VAX_G_double (data, len);
  516.       break;
  517.  
  518.     case LS_VAX_G:
  519.       break;
  520.  
  521.     case LS_CRAY:
  522.       Cray_to_VAX_G_double (data, len);
  523.       break;
  524.  
  525. #else
  526. LOSE! LOSE!
  527. #endif
  528.  
  529.     default:
  530.       gripe_unrecognized_float_fmt ();
  531.       break;
  532.     }
  533. }
  534.  
  535. static void
  536. do_float_format_conversion (float *data, int len,
  537.                 floating_point_format fmt)
  538. {
  539.   switch (fmt)
  540.     {
  541. #if defined (IEEE_LITTLE_ENDIAN)
  542.  
  543.     case LS_IEEE_LITTLE:
  544.       break;
  545.  
  546.     case LS_IEEE_BIG:
  547.       IEEE_big_float_to_IEEE_little_float (data, len);
  548.       break;
  549.  
  550.     case LS_VAX_D:
  551.       VAX_D_float_to_IEEE_little_float (data, len);
  552.       break;
  553.  
  554.     case LS_VAX_G:
  555.       VAX_G_float_to_IEEE_little_float (data, len);
  556.       break;
  557.  
  558.     case LS_CRAY:
  559.       Cray_to_IEEE_little_float (data, len);
  560.       break;
  561.  
  562. #elif defined (IEEE_BIG_ENDIAN)
  563.  
  564.     case LS_IEEE_LITTLE:
  565.       IEEE_little_float_to_IEEE_big_float (data, len);
  566.       break;
  567.  
  568.     case LS_IEEE_BIG:
  569.       break;
  570.  
  571.     case LS_VAX_D:
  572.       VAX_D_float_to_IEEE_big_float (data, len);
  573.       break;
  574.  
  575.     case LS_VAX_G:
  576.       VAX_G_float_to_IEEE_big_float (data, len);
  577.       break;
  578.  
  579.     case LS_CRAY:
  580.       Cray_to_IEEE_big_float (data, len);
  581.       break;
  582.  
  583. #elif defined (VAX_D_FLOAT)
  584.  
  585.     case LS_IEEE_LITTLE:
  586.       IEEE_little_float_to_VAX_D_float (data, len);
  587.       break;
  588.  
  589.     case LS_IEEE_BIG:
  590.       IEEE_big_float_to_VAX_D_float (data, len);
  591.       break;
  592.  
  593.     case LS_VAX_D:
  594.       break;
  595.  
  596.     case LS_VAX_G:
  597.       VAX_G_float_to_VAX_D_float (data, len);
  598.       break;
  599.  
  600.     case LS_CRAY:
  601.       Cray_to_VAX_D_float (data, len);
  602.       break;
  603.  
  604. #elif defined (VAX_G_FLOAT)
  605.  
  606.     case LS_IEEE_LITTLE:
  607.       IEEE_little_float_to_VAX_G_float (data, len);
  608.       break;
  609.  
  610.     case LS_IEEE_BIG:
  611.       IEEE_big_float_to_VAX_G_float (data, len);
  612.       break;
  613.  
  614.     case LS_VAX_D:
  615.       VAX_D_float_to_VAX_G_float (data, len);
  616.       break;
  617.  
  618.     case LS_VAX_G:
  619.       break;
  620.  
  621.     case LS_CRAY:
  622.       Cray_to_VAX_G_float (data, len);
  623.       break;
  624.  
  625. #else
  626. LOSE! LOSE!
  627. #endif
  628.  
  629.     default:
  630.       gripe_unrecognized_float_fmt ();
  631.       break;
  632.     }
  633. }
  634.  
  635. static void
  636. read_doubles (istream& is, double *data, save_type type, int len,
  637.           int swap, floating_point_format fmt)
  638. {
  639.   switch (type)
  640.     {
  641.     case LS_U_CHAR:
  642.       LS_DO_READ (unsigned char, swap, data, 1, len, is);
  643.       break;
  644.  
  645.     case LS_U_SHORT:
  646.       LS_DO_READ (unsigned TWO_BYTE_INT, swap, data, 2, len, is);
  647.       break;
  648.  
  649.     case LS_U_INT:
  650.       LS_DO_READ (unsigned FOUR_BYTE_INT, swap, data, 4, len, is);
  651.       break;
  652.  
  653.     case LS_CHAR:
  654.       LS_DO_READ (signed char, swap, data, 1, len, is);
  655.       break;
  656.  
  657.     case LS_SHORT:
  658.       LS_DO_READ (TWO_BYTE_INT, swap, data, 2, len, is);
  659.       break;
  660.  
  661.     case LS_INT:
  662.       LS_DO_READ (FOUR_BYTE_INT, swap, data, 4, len, is);
  663.       break;
  664.  
  665.     case LS_FLOAT:
  666.       {
  667.     volatile float *ptr = (float *) data;
  668.     is.read (data, 4 * len);
  669.     do_float_format_conversion ((float *) data, len, fmt);
  670.     float tmp = ptr[0];
  671.     for (int i = len - 1; i > 0; i--)
  672.       data[i] = ptr[i];
  673.     data[0] = tmp;
  674.       }
  675.       break;
  676.  
  677.     case LS_DOUBLE:
  678.       is.read (data, 8 * len);
  679.       do_double_format_conversion (data, len, fmt);
  680.       break;
  681.  
  682.     default:
  683.       is.clear (ios::failbit|is.rdstate ());
  684.       break;
  685.     }
  686. }
  687.  
  688. static void
  689. write_doubles (ostream& os, const double *data, save_type type, int len)
  690. {
  691.   switch (type)
  692.     {
  693.     case LS_U_CHAR:
  694.       LS_DO_WRITE (unsigned char, data, 1, len, os);
  695.       break;
  696.  
  697.     case LS_U_SHORT:
  698.       LS_DO_WRITE (unsigned TWO_BYTE_INT, data, 2, len, os);
  699.       break;
  700.  
  701.     case LS_U_INT:
  702.       LS_DO_WRITE (unsigned FOUR_BYTE_INT, data, 4, len, os);
  703.       break;
  704.  
  705.     case LS_CHAR:
  706.       LS_DO_WRITE (signed char, data, 1, len, os);
  707.       break;
  708.  
  709.     case LS_SHORT:
  710.       LS_DO_WRITE (TWO_BYTE_INT, data, 2, len, os);
  711.       break;
  712.  
  713.     case LS_INT:
  714.       LS_DO_WRITE (FOUR_BYTE_INT, data, 4, len, os);
  715.       break;
  716.  
  717.     case LS_FLOAT:
  718.       LS_DO_WRITE (float, data, 4, len, os);
  719.       break;
  720.  
  721.     case LS_DOUBLE:
  722.       {
  723.     char tmp_type = (char) type;
  724.     os.write (&tmp_type, 1);
  725.     os.write (data, 8 * len);
  726.       }
  727.       break;
  728.  
  729.     default:
  730.       error ("unrecognized data format requested");
  731.       break;
  732.     }
  733. }
  734.  
  735. // Return nonzero if S is a valid identifier.
  736.  
  737. static int
  738. valid_identifier (char *s)
  739. {
  740.   if (! s || ! (isalnum (*s) || *s == '_'))
  741.      return 0;
  742.  
  743.   while (*++s != '\0')
  744.     if (! (isalnum (*s) || *s == '_'))
  745.       return 0;
  746.  
  747.   return 1;
  748. }
  749.  
  750. // Return nonzero if any element of M is not an integer.  Also extract
  751. // the largest and smallest values and return them in MAX_VAL and MIN_VAL.
  752.  
  753. static int
  754. all_parts_int (const Matrix& m, double& max_val, double& min_val)
  755. {
  756.   int nr = m.rows ();
  757.   int nc = m.columns ();
  758.  
  759.   if (nr > 0 && nc > 0)
  760.     {
  761.       max_val = m.elem (0, 0);
  762.       min_val = m.elem (0, 0);
  763.     }
  764.   else
  765.     return 0;
  766.  
  767.   for (int j = 0; j < nc; j++)
  768.     for (int i = 0; i < nr; i++)
  769.       {
  770.     double val = m.elem (i, j);
  771.  
  772.     if (val > max_val)
  773.       max_val = val;
  774.  
  775.     if (val < min_val)
  776.       min_val = val;
  777.  
  778.     if (D_NINT (val) != val)
  779.       return 0;
  780.       }
  781.   return 1;
  782. }
  783.  
  784. // Return nonzero if any element of CM has a non-integer real or
  785. // imaginary part.  Also extract the largest and smallest (real or
  786. // imaginary) values and return them in MAX_VAL and MIN_VAL. 
  787.  
  788. static int
  789. all_parts_int (const ComplexMatrix& m, double& max_val, double& min_val)
  790. {
  791.   int nr = m.rows ();
  792.   int nc = m.columns ();
  793.  
  794.   if (nr > 0 && nc > 0)
  795.     {
  796.       Complex val = m.elem (0, 0);
  797.  
  798.       double r_val = real (val);
  799.       double i_val = imag (val);
  800.  
  801.       max_val = r_val;
  802.       min_val = r_val;
  803.  
  804.       if (i_val > max_val)
  805.     max_val = i_val;
  806.  
  807.       if (i_val < max_val)
  808.     min_val = i_val;
  809.     }
  810.   else
  811.     return 0;
  812.  
  813.   for (int j = 0; j < nc; j++)
  814.     for (int i = 0; i < nr; i++)
  815.       {
  816.     Complex val = m.elem (i, j);
  817.  
  818.     double r_val = real (val);
  819.     double i_val = imag (val);
  820.  
  821.     if (r_val > max_val)
  822.       max_val = r_val;
  823.  
  824.     if (i_val > max_val)
  825.       max_val = i_val;
  826.  
  827.     if (r_val < min_val)
  828.       min_val = r_val;
  829.  
  830.     if (i_val < min_val)
  831.       min_val = i_val;
  832.  
  833.     if (D_NINT (r_val) != r_val || D_NINT (i_val) != i_val)
  834.       return 0;
  835.       }
  836.   return 1;
  837. }
  838.  
  839. static int
  840. too_large_for_float (const Matrix& m)
  841. {
  842.   int nr = m.rows ();
  843.   int nc = m.columns ();
  844.  
  845.   for (int j = 0; j < nc; j++)
  846.     for (int i = 0; i < nr; i++)
  847.       {
  848.     Complex val = m.elem (i, j);
  849.  
  850.     double r_val = real (val);
  851.     double i_val = imag (val);
  852.  
  853.     if (r_val > FLT_MAX
  854.         || i_val > FLT_MAX
  855.         || r_val < FLT_MIN
  856.         || i_val < FLT_MIN)
  857.       return 1;
  858.       }
  859.  
  860.   return 0;
  861. }
  862.  
  863. static int
  864. too_large_for_float (const ComplexMatrix& m)
  865. {
  866.   int nr = m.rows ();
  867.   int nc = m.columns ();
  868.  
  869.   for (int j = 0; j < nc; j++)
  870.     for (int i = 0; i < nr; i++)
  871.       {
  872.     Complex val = m.elem (i, j);
  873.  
  874.     double r_val = real (val);
  875.     double i_val = imag (val);
  876.  
  877.     if (r_val > FLT_MAX
  878.         || i_val > FLT_MAX
  879.         || r_val < FLT_MIN
  880.         || i_val < FLT_MIN)
  881.       return 1;
  882.       }
  883.  
  884.   return 0;
  885. }
  886.  
  887. // XXX FIXME XXX -- shouldn't this be implemented in terms of other
  888. // functions that are already available?
  889.  
  890. // Install a variable with name NAME and the value specified TC in the
  891. // symbol table.  If FORCE is nonzero, replace any existing definition
  892. // for NAME.  If GLOBAL is nonzero, make the variable global.
  893. //
  894. // Assumes TC is defined.
  895.  
  896. static void
  897. install_loaded_variable (int force, char *name, const tree_constant& tc,
  898.              int global, char *doc)
  899. {
  900. // Is there already a symbol by this name?  If so, what is it?
  901.  
  902.   symbol_record *lsr = curr_sym_tab->lookup (name, 0, 0);
  903.  
  904.   int is_undefined = 1;
  905.   int is_variable = 0;
  906.   int is_function = 0;
  907.   int is_global = 0;
  908.  
  909.   if (lsr)
  910.     {
  911.       is_undefined = ! lsr->is_defined ();
  912.       is_variable = lsr->is_variable ();
  913.       is_function = lsr->is_function ();
  914.       is_global = lsr->is_linked_to_global ();
  915.     }
  916.  
  917.   symbol_record *sr = 0;
  918.  
  919.   if (global)
  920.     {
  921.       if (is_global || is_undefined)
  922.     {
  923.       if (force || is_undefined)
  924.         {
  925.           lsr = curr_sym_tab->lookup (name, 1, 0);
  926.           link_to_global_variable (lsr);
  927.           sr = lsr;
  928.         }
  929.       else
  930.         {
  931.           warning ("load: global variable name `%s' exists.", name);
  932.           warning ("use `load -force' to overwrite");
  933.         }
  934.     }
  935.       else if (is_function)
  936.     {
  937.       if (force)
  938.         {
  939.           lsr = curr_sym_tab->lookup (name, 1, 0);
  940.           link_to_global_variable (lsr);
  941.           sr = lsr;
  942.         }
  943.       else
  944.         {
  945.           warning ("load: `%s' is currently a function in this scope", name);
  946.           warning ("`load -force' will load variable and hide function");
  947.         }
  948.     }
  949.       else if (is_variable)
  950.     {
  951.       if (force)
  952.         {
  953.           lsr = curr_sym_tab->lookup (name, 1, 0);
  954.           link_to_global_variable (lsr);
  955.           sr = lsr;
  956.         }
  957.       else
  958.         {
  959.           warning ("load: local variable name `%s' exists.", name);
  960.           warning ("use `load -force' to overwrite");
  961.         }
  962.     }
  963.       else
  964.     error ("load: unable to load data for unknown symbol type");
  965.     }
  966.   else
  967.     {
  968.       if (is_global)
  969.     {
  970.       if (force || is_undefined)
  971.         {
  972.           lsr = curr_sym_tab->lookup (name, 1, 0);
  973.           link_to_global_variable (lsr);
  974.           sr = lsr;
  975.         }
  976.       else
  977.         {
  978.           warning ("load: global variable name `%s' exists.", name);
  979.           warning ("use `load -force' to overwrite");
  980.         }
  981.     }
  982.       else if (is_function)
  983.     {
  984.       if (force)
  985.         {
  986.           lsr = curr_sym_tab->lookup (name, 1, 0);
  987.           link_to_global_variable (lsr);
  988.           sr = lsr;
  989.         }
  990.       else
  991.         {
  992.           warning ("load: `%s' is currently a function in this scope", name);
  993.           warning ("`load -force' will load variable and hide function");
  994.         }
  995.     }
  996.       else if (is_variable || is_undefined)
  997.     {
  998.       if (force || is_undefined)
  999.         {
  1000.           lsr = curr_sym_tab->lookup (name, 1, 0);
  1001.           sr = lsr;
  1002.         }
  1003.       else
  1004.         {
  1005.           warning ("load: local variable name `%s' exists.", name);
  1006.           warning ("use `load -force' to overwrite");
  1007.         }
  1008.     }
  1009.       else
  1010.     error ("load: unable to load data for unknown symbol type");
  1011.     }
  1012.  
  1013.   if (sr)
  1014.     {
  1015.       tree_constant *tmp_tc = new tree_constant (tc);
  1016.       sr->define (tmp_tc);
  1017.       if (doc)
  1018.     sr->document (doc);
  1019.       return;
  1020.     }
  1021.   else
  1022.     error ("load: unable to load variable `%s'", name);
  1023.  
  1024.   return;
  1025. }
  1026.  
  1027. // Functions for reading ascii data.
  1028.  
  1029. // Skip white space and comments on stream IS.
  1030.  
  1031. static void
  1032. skip_comments (istream& is)
  1033. {
  1034.   char c = '\0';
  1035.   while (is.get (c))
  1036.     {
  1037.       if (c == ' ' || c == '\t' || c == '\n')
  1038.     ; // Skip whitespace on way to beginning of next line.
  1039.       else
  1040.     break;
  1041.     }
  1042.  
  1043.   for (;;)
  1044.     {
  1045.       if (is && c == '#')
  1046.     while (is.get (c) && c != '\n')
  1047.       ; // Skip to beginning of next line, ignoring everything.
  1048.       else
  1049.     break;
  1050.     }
  1051. }
  1052.  
  1053. // Extract a KEYWORD and its value from stream IS, returning the
  1054. // associated value in a new string.
  1055. //
  1056. // Input should look something like:
  1057. //
  1058. //  #[ \t]*keyword[ \t]*:[ \t]*string-value[ \t]*\n
  1059.  
  1060. static char *
  1061. extract_keyword (istream& is, char *keyword)
  1062. {
  1063.   ostrstream buf;
  1064.  
  1065.   char *retval = 0;
  1066.  
  1067.   char c;
  1068.   while (is.get (c))
  1069.     {
  1070.       if (c == '#')
  1071.     {
  1072.       while (is.get (c) && (c == ' ' || c == '\t' || c == '#'))
  1073.         ; // Skip whitespace and comment characters.
  1074.  
  1075.       if (isalpha (c))
  1076.         buf << c;
  1077.  
  1078.       while (is.get (c) && isalpha (c))
  1079.         buf << c;
  1080.  
  1081.       buf << ends;
  1082.       char *tmp = buf.str ();
  1083.       int match = (strncmp (tmp, keyword, strlen (keyword)) == 0);
  1084.       delete [] tmp;
  1085.  
  1086.       if (match)
  1087.         {
  1088.           ostrstream value;
  1089.           while (is.get (c) && (c == ' ' || c == '\t' || c == ':'))
  1090.         ; // Skip whitespace and the colon.
  1091.  
  1092.           if (c != '\n')
  1093.         {
  1094.           value << c;
  1095.           while (is.get (c) && c != '\n')
  1096.             value << c;
  1097.         }
  1098.           value << ends;
  1099.           retval = value.str ();
  1100.           break;
  1101.         }
  1102.     }
  1103.     }
  1104.  
  1105.   if (retval)
  1106.     {
  1107.       int len = strlen (retval);
  1108.       if (len > 0)
  1109.     {
  1110.       char *ptr = retval + len - 1;
  1111.       while (*ptr == ' ' || *ptr == '\t')
  1112.         ptr--;
  1113.       *(ptr+1) = '\0';
  1114.     }
  1115.     }
  1116.  
  1117.   return retval;
  1118. }
  1119.  
  1120. // Match KEYWORD on stream IS, placing the associated value in VALUE,
  1121. // returning 1 if successful and 0 otherwise.
  1122. //
  1123. // Input should look something like:
  1124. //
  1125. //  [ \t]*keyword[ \t]*int-value.*\n
  1126.  
  1127. static int
  1128. extract_keyword (istream& is, char *keyword, int& value)
  1129. {
  1130.   ostrstream buf;
  1131.  
  1132.   int status = 0;
  1133.   value = 0;
  1134.  
  1135.   char c;
  1136.   while (is.get (c))
  1137.     {
  1138.       if (c == '#')
  1139.     {
  1140.       while (is.get (c) && (c == ' ' || c == '\t' || c == '#'))
  1141.         ; // Skip whitespace and comment characters.
  1142.  
  1143.       if (isalpha (c))
  1144.         buf << c;
  1145.  
  1146.       while (is.get (c) && isalpha (c))
  1147.         buf << c;
  1148.  
  1149.       buf << ends;
  1150.       char *tmp = buf.str ();
  1151.       int match = (strncmp (tmp, keyword, strlen (keyword)) == 0);
  1152.       delete [] tmp;
  1153.  
  1154.       if (match)
  1155.         {
  1156.           while (is.get (c) && (c == ' ' || c == '\t' || c == ':'))
  1157.         ; // Skip whitespace and the colon.
  1158.  
  1159.           is.putback (c);
  1160.           if (c != '\n')
  1161.         is >> value;
  1162.           if (is)
  1163.         status = 1;
  1164.           while (is.get (c) && c != '\n')
  1165.         ; // Skip to beginning of next line;
  1166.           break;
  1167.         }
  1168.     }
  1169.     }
  1170.   return status;
  1171. }
  1172.  
  1173. // Extract one value (scalar, matrix, string, etc.) from stream IS and
  1174. // place it in TC, returning the name of the variable.  If the value
  1175. // is tagged as global in the file, return nonzero in GLOBAL.
  1176. //
  1177. // FILENAME is used for error messages.
  1178. //
  1179. // The data is expected to be in the following format:
  1180. //
  1181. // The input file must have a header followed by some data.
  1182. //
  1183. // All lines in the header must begin with a `#' character.
  1184. //
  1185. // The header must contain a list of keyword and value pairs with the
  1186. // keyword and value separated by a colon.
  1187. //
  1188. // Keywords must appear in the following order:
  1189. //
  1190. // # name: <name>
  1191. // # type: <type>
  1192. // # <info>
  1193. //
  1194. // Where:
  1195. //
  1196. //  <name> : a valid identifier
  1197. //
  1198. //  <type> : <typename>
  1199. //         | global <typename>
  1200. //
  1201. //  <typename> : scalar
  1202. //             | complex scalar
  1203. //             | matrix
  1204. //             | complex matrix
  1205. //             | string
  1206. //             | range
  1207. //
  1208. //  <info> : <matrix info>
  1209. //         | <string info>
  1210. //
  1211. //  <matrix info> : # rows: <integer>
  1212. //                | # columns: <integer>
  1213. //
  1214. //  <string info> : # len: <integer>
  1215. //
  1216. // Formatted ASCII data follows the header.
  1217. //
  1218. // Example:
  1219. //
  1220. //  # name: foo
  1221. //  # type: matrix
  1222. //  # rows: 2
  1223. //  # columns: 2
  1224. //    2  4
  1225. //    1  3
  1226. //
  1227. // XXX FIXME XXX -- this format is fairly rigid, and doesn't allow for
  1228. // arbitrary comments, etc.  Someone should fix that.
  1229.  
  1230. static char *
  1231. read_ascii_data (istream& is, const char *filename, int& global,
  1232.          tree_constant& tc)
  1233. {
  1234. // Read name for this entry or break on EOF.
  1235.  
  1236.   char *name = extract_keyword (is, "name");
  1237.  
  1238.   if (! name)
  1239.     return 0;
  1240.  
  1241.   if (! *name)
  1242.     {
  1243.       error ("load: empty name keyword found in file `%s'", filename);
  1244.       delete [] name;
  1245.       return 0;
  1246.     }
  1247.       
  1248.  
  1249.   if (! valid_identifier (name))
  1250.     {
  1251.       error ("load: bogus identifier `%s' found in file `%s'", name, filename);
  1252.       delete [] name;
  1253.       return 0;
  1254.     }
  1255.  
  1256. // Look for type keyword
  1257.  
  1258.   char *tag = extract_keyword (is, "type");
  1259.  
  1260.   if (tag && *tag)
  1261.     {
  1262.       char *ptr = strchr (tag, ' ');
  1263.       if (ptr)
  1264.     {
  1265.       *ptr = '\0';
  1266.       global = (strncmp (tag, "global", 6) == 0);
  1267.       *ptr = ' ';
  1268.       if (global)
  1269.         ptr++;
  1270.       else
  1271.         ptr = tag;
  1272.     }
  1273.       else
  1274.     ptr = tag;
  1275.  
  1276.       if (strncmp (ptr, "scalar", 6) == 0)
  1277.     {
  1278.       double tmp;
  1279.       is >> tmp;
  1280.       if (is)
  1281.         tc = tmp;
  1282.       else
  1283.         error ("load: failed to load scalar constant");
  1284.     }
  1285.       else if (strncmp (ptr, "matrix", 6) == 0)
  1286.     {
  1287.       int nr = 0, nc = 0;
  1288.  
  1289.       if (extract_keyword (is, "rows", nr) && nr > 0
  1290.           && extract_keyword (is, "columns", nc) && nc > 0)
  1291.         {
  1292.           Matrix tmp (nr, nc);
  1293.           is >> tmp;
  1294.           if (is)
  1295.         tc = tmp;
  1296.           else
  1297.         error ("load: failed to load matrix constant");
  1298.         }
  1299.       else
  1300.         error ("load: failed to extract number of rows and columns");
  1301.     }
  1302.       else if (strncmp (ptr, "complex scalar", 14) == 0)
  1303.     {
  1304.       Complex tmp;
  1305.       is >> tmp;
  1306.       if (is)
  1307.         tc = tmp;
  1308.       else
  1309.         error ("load: failed to load complex scalar constant");
  1310.     }
  1311.       else if (strncmp (ptr, "complex matrix", 14) == 0)
  1312.     {
  1313.       int nr = 0, nc = 0;
  1314.  
  1315.       if (extract_keyword (is, "rows", nr) && nr > 0
  1316.           && extract_keyword (is, "columns", nc) && nc > 0)
  1317.         {
  1318.           ComplexMatrix tmp (nr, nc);
  1319.           is >> tmp;
  1320.           if (is)
  1321.         tc = tmp;
  1322.           else
  1323.         error ("load: failed to load complex matrix constant");
  1324.         }
  1325.       else
  1326.         error ("load: failed to extract number of rows and columns");
  1327.     }
  1328.       else if (strncmp (ptr, "string", 6) == 0)
  1329.     {
  1330.       int len;
  1331.       if (extract_keyword (is, "length", len) && len > 0)
  1332.         {
  1333.           char *tmp = new char [len+1];
  1334.           is.get (tmp, len+1, EOF);
  1335.           if (is)
  1336.         tc = tmp;
  1337.           else
  1338.         error ("load: failed to load string constant");
  1339.         }
  1340.       else
  1341.         error ("load: failed to extract string length");
  1342.     }
  1343.       else if (strncmp (ptr, "range", 5) == 0)
  1344.     {
  1345. // # base, limit, range comment added by save().
  1346.       skip_comments (is);
  1347.       Range tmp;
  1348.       is >> tmp;
  1349.       if (is)
  1350.         tc = tmp;
  1351.       else
  1352.         error ("load: failed to load range constant");
  1353.     }
  1354.       else
  1355.     error ("load: unknown constant type `%s'", tag);
  1356.     }
  1357.   else
  1358.     error ("load: failed to extract keyword specifying value type");
  1359.  
  1360.   delete [] tag;
  1361.  
  1362.   if (error_state)
  1363.     {
  1364.       error ("load: reading file %s", filename);
  1365.       return 0;
  1366.     }
  1367.  
  1368.   return name;
  1369. }
  1370.  
  1371. // Extract one value (scalar, matrix, string, etc.) from stream IS and
  1372. // place it in TC, returning the name of the variable.  If the value
  1373. // is tagged as global in the file, return nonzero in GLOBAL.  If SWAP
  1374. // is nonzero, swap bytes after reading.
  1375. //
  1376. // The data is expected to be in the following format:
  1377. //
  1378. // Header (one per file):
  1379. // =====================
  1380. //
  1381. //   object               type            bytes
  1382. //   ------               ----            -----
  1383. //   magic number         string             10
  1384. //
  1385. //   float format         integer             1  
  1386. //
  1387. //
  1388. // Data (one set for each item):
  1389. // ============================
  1390. //
  1391. //   object               type            bytes
  1392. //   ------               ----            -----
  1393. //   name_length          integer             4
  1394. //
  1395. //   name                 string    name_length
  1396. //
  1397. //   doc_length           integer             4
  1398. //
  1399. //   doc                  string     doc_length
  1400. //
  1401. //   global flag          integer             1
  1402. //
  1403. //   data type            integer             1
  1404. //
  1405. //   data (one of):
  1406. //
  1407. //     scalar:
  1408. //       data             real                8
  1409. //
  1410. //     complex scalar:
  1411. //       data             complex            16
  1412. //
  1413. //     matrix:
  1414. //       rows             integer             4
  1415. //       columns          integer             4
  1416. //       data             real            r*c*8
  1417. //
  1418. //     complex matrix:
  1419. //       rows             integer             4
  1420. //       columns          integer             4
  1421. //       data             complex        r*c*16
  1422. //
  1423. //     string:
  1424. //       length           int                 4
  1425. //       data             string         length
  1426. //
  1427. //     range:
  1428. //       base             real                8
  1429. //       limit            real                8
  1430. //       increment        real                8
  1431. //
  1432. // FILENAME is used for error messages.
  1433.  
  1434. static char *
  1435. read_binary_data (istream& is, int swap, floating_point_format fmt,
  1436.           const char *filename, int& global,
  1437.           tree_constant& tc, char *&doc)
  1438. {
  1439.   char tmp = 0;
  1440.  
  1441.   FOUR_BYTE_INT name_len = 0, doc_len = 0;
  1442.   char *name = 0;
  1443.  
  1444.   doc = 0;
  1445.  
  1446. // We expect to fail here, at the beginning of a record, so not being
  1447. // able to read another name should not result in an error.
  1448.  
  1449.   is.read (&name_len, 4);
  1450.   if (! is)
  1451.     return 0;
  1452.   if (swap)
  1453.     swap_4_bytes ((char *) &name_len);
  1454.  
  1455.   name = new char [name_len+1];
  1456.   name[name_len] = '\0';
  1457.   if (! is.read (name, name_len))
  1458.     goto data_read_error;
  1459.  
  1460.   is.read (&doc_len, 4);
  1461.   if (! is)
  1462.     goto data_read_error;
  1463.   if (swap)
  1464.     swap_4_bytes ((char *) &doc_len);
  1465.  
  1466.   doc = new char [doc_len+1];
  1467.   doc[doc_len] = '\0';
  1468.   if (! is.read (doc, doc_len))
  1469.     goto data_read_error;
  1470.  
  1471.   if (! is.read (&tmp, 1))
  1472.     goto data_read_error;
  1473.   global = tmp ? 1 : 0;
  1474.  
  1475.   tmp = 0;
  1476.   if (! is.read (&tmp, 1))
  1477.     goto data_read_error;
  1478.  
  1479.   switch (tmp)
  1480.     {
  1481.     case 1:
  1482.       {
  1483.     if (! is.read (&tmp, 1))
  1484.       goto data_read_error;
  1485.     double dtmp;
  1486.     read_doubles (is, &dtmp, (save_type) tmp, 1, swap, fmt);
  1487.     if (error_state || ! is)
  1488.       goto data_read_error;
  1489.     tc = dtmp;
  1490.       }
  1491.       break;
  1492.  
  1493.     case 2:
  1494.       {
  1495.     FOUR_BYTE_INT nr, nc;
  1496.     if (! is.read (&nr, 4))
  1497.       goto data_read_error;
  1498.     if (swap)
  1499.       swap_4_bytes ((char *) &nr);
  1500.     if (! is.read (&nc, 4))
  1501.       goto data_read_error;
  1502.     if (swap)
  1503.       swap_4_bytes ((char *) &nc);
  1504.     if (! is.read (&tmp, 1))
  1505.       goto data_read_error;
  1506.     Matrix m (nr, nc);
  1507.     double *re = m.fortran_vec ();
  1508.     int len = nr * nc;
  1509.     read_doubles (is, re, (save_type) tmp, len, swap, fmt);
  1510.     if (error_state || ! is)
  1511.       goto data_read_error;
  1512.     tc = m;
  1513.       }
  1514.       break;
  1515.  
  1516.     case 3:
  1517.       {
  1518.     if (! is.read (&tmp, 1))
  1519.       goto data_read_error;
  1520.     Complex ctmp;
  1521.     read_doubles (is, (double *) &ctmp, (save_type) tmp, 2, swap, fmt);
  1522.     if (error_state || ! is)
  1523.       goto data_read_error;
  1524.     tc = ctmp;
  1525.       }
  1526.       break;
  1527.  
  1528.     case 4:
  1529.       {
  1530.     FOUR_BYTE_INT nr, nc;
  1531.     if (! is.read (&nr, 4))
  1532.       goto data_read_error;
  1533.     if (swap)
  1534.       swap_4_bytes ((char *) &nr);
  1535.     if (! is.read (&nc, 4))
  1536.       goto data_read_error;
  1537.     if (swap)
  1538.       swap_4_bytes ((char *) &nc);
  1539.     if (! is.read (&tmp, 1))
  1540.       goto data_read_error;
  1541.     ComplexMatrix m (nr, nc);
  1542.     Complex *im = m.fortran_vec ();
  1543.     int len = nr * nc;
  1544.     read_doubles (is, (double *) im, (save_type) tmp, 2*len,
  1545.               swap, fmt);
  1546.     if (error_state || ! is)
  1547.       goto data_read_error;
  1548.     tc = m;
  1549.       }
  1550.       break;
  1551.  
  1552.     case 5:
  1553.       {
  1554.     int nr = tc.rows ();
  1555.     int nc = tc.columns ();
  1556.     FOUR_BYTE_INT len = nr * nc;
  1557.     if (! is.read (&len, 4))
  1558.       goto data_read_error;
  1559.     if (swap)
  1560.       swap_4_bytes ((char *) &len);
  1561.     char *s = new char [len+1];
  1562.     if (! is.read (s, len))
  1563.       {
  1564.         delete [] s;
  1565.         goto data_read_error;
  1566.       }
  1567.     s[len] = '\0';
  1568.     tc = s;
  1569.       }
  1570.       break;
  1571.  
  1572.     case 6:
  1573.       {
  1574.     if (! is.read (&tmp, 1))
  1575.       goto data_read_error;
  1576.     double bas, lim, inc;
  1577.     if (! is.read (&bas, 8))
  1578.       goto data_read_error;
  1579.     if (swap)
  1580.       swap_8_bytes ((char *) &bas);
  1581.     if (! is.read (&lim, 8))
  1582.       goto data_read_error;
  1583.     if (swap)
  1584.       swap_8_bytes ((char *) &lim);
  1585.     if (! is.read (&inc, 8))
  1586.       goto data_read_error;
  1587.     if (swap)
  1588.       swap_8_bytes ((char *) &inc);
  1589.     Range r (bas, lim, inc);
  1590.     tc = r;
  1591.       }
  1592.       break;
  1593.  
  1594.     default:
  1595.     data_read_error:
  1596.       error ("load: trouble reading binary file `%s'", filename);
  1597.       delete [] name;
  1598.       name = 0;
  1599.       break;
  1600.     }
  1601.  
  1602.   return name;
  1603. }
  1604.  
  1605. // Read LEN elements of data from IS in the format specified by
  1606. // PRECISION, placing the result in DATA.  If SWAP is nonzero, swap
  1607. // the bytes of each element before copying to DATA.  FLT_FMT
  1608. // specifies the format of the data if we are reading floating point
  1609. // numbers.
  1610.  
  1611. static void
  1612. read_mat_binary_data (istream& is, double *data, int precision,
  1613.               int len, int swap, floating_point_format flt_fmt)
  1614. {
  1615.   switch (precision)
  1616.     {
  1617.     case 0:
  1618.       read_doubles (is, data, LS_DOUBLE, len, swap, flt_fmt);
  1619.       break;
  1620.  
  1621.     case 1:
  1622.       read_doubles (is, data, LS_FLOAT, len, swap, flt_fmt);
  1623.       break;
  1624.  
  1625.     case 2:
  1626.       read_doubles (is, data, LS_INT, len, swap, flt_fmt);
  1627.       break;
  1628.  
  1629.     case 3:
  1630.       read_doubles (is, data, LS_SHORT, len, swap, flt_fmt);
  1631.       break;
  1632.  
  1633.     case 4:
  1634.       read_doubles (is, data, LS_U_SHORT, len, swap, flt_fmt);
  1635.       break;
  1636.  
  1637.     case 5:
  1638.       read_doubles (is, data, LS_U_CHAR, len, swap, flt_fmt);
  1639.       break;
  1640.  
  1641.     default:
  1642.       break;
  1643.     }
  1644. }
  1645.  
  1646. static int
  1647. read_mat_file_header (istream& is, int& swap, FOUR_BYTE_INT& mopt, 
  1648.               FOUR_BYTE_INT& nr, FOUR_BYTE_INT& nc,
  1649.               FOUR_BYTE_INT& imag, FOUR_BYTE_INT& len,
  1650.               int quiet = 0)
  1651. {
  1652.   swap = 0;
  1653.  
  1654. // We expect to fail here, at the beginning of a record, so not being
  1655. // able to read another mopt value should not result in an error. 
  1656.  
  1657.   is.read (&mopt, 4);
  1658.   if (! is)
  1659.     return 1;
  1660.  
  1661.   if (! is.read (&nr, 4))
  1662.     goto data_read_error;
  1663.  
  1664.   if (! is.read (&nc, 4))
  1665.     goto data_read_error;
  1666.  
  1667.   if (! is.read (&imag, 4))
  1668.     goto data_read_error;
  1669.  
  1670.   if (! is.read (&len, 4))
  1671.     goto data_read_error;
  1672.  
  1673. // If mopt is nonzero and the byte order is swapped, mopt will be
  1674. // bigger than we expect, so we swap bytes.
  1675. //
  1676. // If mopt is zero, it means the file was written on a little endian
  1677. // machine, and we only need to swap if we are running on a big endian
  1678. // machine.
  1679. //
  1680. // Gag me.
  1681.  
  1682. #if defined (WORDS_BIGENDIAN)
  1683.   if (mopt == 0)
  1684.     swap = 1;
  1685. #endif
  1686.  
  1687. // mopt is signed, therefore byte swap may result in negative value.
  1688.  
  1689.   if (mopt > 9999 || mopt < 0)
  1690.     swap = 1;
  1691.  
  1692.   if (swap)
  1693.     {
  1694.       swap_4_bytes ((char *) &mopt);
  1695.       swap_4_bytes ((char *) &nr);
  1696.       swap_4_bytes ((char *) &nc);
  1697.       swap_4_bytes ((char *) &imag);
  1698.       swap_4_bytes ((char *) &len);
  1699.     }
  1700.  
  1701.   if (mopt > 9999 || mopt < 0 || imag > 1 || imag < 0)
  1702.     {
  1703.       if (! quiet)
  1704.     error ("load: can't read binary file");
  1705.       return -1;
  1706.     }
  1707.  
  1708.   return 0;
  1709.  
  1710.  data_read_error:
  1711.   return -1;
  1712. }
  1713.  
  1714. // We don't just use a cast here, because we need to be able to detect
  1715. // possible errors.
  1716.  
  1717. static floating_point_format
  1718. get_floating_point_format (int mach)
  1719. {
  1720.   floating_point_format flt_fmt = LS_UNKNOWN_FLT_FMT;
  1721.  
  1722.   switch (mach)
  1723.     {
  1724.     case 0:
  1725.       flt_fmt = LS_IEEE_LITTLE;
  1726.       break;
  1727.  
  1728.     case 1:
  1729.       flt_fmt = LS_IEEE_BIG;
  1730.       break;
  1731.  
  1732.     case 2:
  1733.       flt_fmt = LS_VAX_D;
  1734.       break;
  1735.  
  1736.     case 3:
  1737.       flt_fmt = LS_VAX_G;
  1738.       break;
  1739.  
  1740.     case 4:
  1741.       flt_fmt = LS_CRAY;
  1742.       break;
  1743.  
  1744.     default:
  1745.       flt_fmt = LS_UNKNOWN_FLT_FMT;
  1746.       break;
  1747.     }
  1748.  
  1749.   return flt_fmt;
  1750. }
  1751.  
  1752. // Extract one value (scalar, matrix, string, etc.) from stream IS and
  1753. // place it in TC, returning the name of the variable.
  1754. //
  1755. // The data is expected to be in Matlab's .mat format, though not all
  1756. // the features of that format are supported.
  1757. //
  1758. // FILENAME is used for error messages.
  1759. //
  1760. // This format provides no way to tag the data as global.
  1761.  
  1762. static char *
  1763. read_mat_binary_data (istream& is, const char *filename,
  1764.               tree_constant& tc)
  1765. {
  1766. // These are initialized here instead of closer to where they are
  1767. // first used to avoid errors from gcc about goto crossing
  1768. // initialization of variable.
  1769.  
  1770.   Matrix re;
  1771.   floating_point_format flt_fmt = LS_UNKNOWN_FLT_FMT;
  1772.   char *name = 0;
  1773.   int swap = 0, type = 0, prec = 0, mach = 0, dlen = 0;
  1774.  
  1775.   FOUR_BYTE_INT mopt, nr, nc, imag, len;
  1776.  
  1777.   int err = read_mat_file_header (is, swap, mopt, nr, nc, imag, len);
  1778.   if (err)
  1779.     {
  1780.       if (err < 0)
  1781.     goto data_read_error;
  1782.       else
  1783.     return 0;
  1784.     }
  1785.  
  1786.   type = mopt % 10; // Full, sparse, etc.
  1787.   mopt /= 10;       // Eliminate first digit.
  1788.   prec = mopt % 10; // double, float, int, etc.
  1789.   mopt /= 100;      // Skip unused third digit too.
  1790.   mach = mopt % 10; // IEEE, VAX, etc.
  1791.  
  1792.   flt_fmt = get_floating_point_format (mach);
  1793.   if (flt_fmt == LS_UNKNOWN_FLT_FMT)
  1794.     {
  1795.       error ("load: unrecognized binary format!");
  1796.       return 0;
  1797.     }
  1798.  
  1799.   if (type != 0 && type != 1)
  1800.     {
  1801.       error ("load: can't read sparse matrices");
  1802.       return 0;
  1803.     }
  1804.  
  1805.   if (imag && type == 1)
  1806.     {
  1807.       error ("load: encountered complex matrix with string flag set!");
  1808.       return 0;
  1809.     }
  1810.  
  1811.   name = new char [len];
  1812.   if (! is.read (name, len))
  1813.     goto data_read_error;
  1814.  
  1815.   dlen = nr * nc;
  1816.   if (dlen < 0)
  1817.     goto data_read_error;
  1818.  
  1819.   re.resize (nr, nc);
  1820.  
  1821.   read_mat_binary_data (is, re.fortran_vec (), prec, dlen, swap, flt_fmt);
  1822.  
  1823.   if (! is || error_state)
  1824.     {
  1825.       error ("load: reading matrix data for `%s'", name);
  1826.       goto data_read_error;
  1827.     }
  1828.  
  1829.   if (imag)
  1830.     {
  1831.       Matrix im (nr, nc);
  1832.  
  1833.       read_mat_binary_data (is, im.fortran_vec (), prec, dlen, swap, flt_fmt);
  1834.  
  1835.       if (! is || error_state)
  1836.     {
  1837.       error ("load: reading imaginary matrix data for `%s'", name);
  1838.       goto data_read_error;
  1839.     }
  1840.  
  1841.       ComplexMatrix ctmp (nr, nc);
  1842.  
  1843.       for (int j = 0; j < nc; j++)
  1844.     for (int i = 0; i < nr; i++)
  1845.       ctmp.elem (i, j) = Complex (re.elem (i, j), im.elem (i, j));
  1846.  
  1847.       tc = ctmp;
  1848.     }
  1849.   else
  1850.     tc = re;
  1851.  
  1852. // XXX FIXME XXX -- this needs to change once strings really work.
  1853.  
  1854.   if (type == 1 && nr == 1)
  1855.     tc = tc.convert_to_str ();
  1856.  
  1857.   return name;
  1858.  
  1859.  data_read_error:
  1860.   error ("load: trouble reading binary file `%s'", filename);
  1861.   delete [] name;
  1862.   return 0;
  1863. }
  1864.  
  1865. // Return nonzero if NAME matches one of the given globbing PATTERNS.
  1866.  
  1867. static int
  1868. matches_patterns (char **patterns, int num_pat, char *name)
  1869. {
  1870.   while (num_pat-- > 0)
  1871.     {
  1872.       if (fnmatch (*patterns++, name, __FNM_FLAGS) == 0)
  1873.     return 1;
  1874.     }
  1875.   return 0;
  1876. }
  1877.  
  1878. static int
  1879. read_binary_file_header (istream& is, int& swap,
  1880.              floating_point_format& flt_fmt, int quiet = 0) 
  1881. {
  1882.   int magic_len = 10;
  1883.   char magic [magic_len+1];
  1884.   is.read (magic, magic_len);
  1885.   magic[magic_len] = '\0';
  1886.   if (strncmp (magic, "Octave-1-L", magic_len) == 0)
  1887.     {
  1888. #if defined (WORDS_BIGENDIAN)
  1889.       swap = 1;
  1890. #else
  1891.       swap = 0;
  1892. #endif
  1893.     }
  1894.   else if (strncmp (magic, "Octave-1-B", magic_len) == 0)
  1895.     {
  1896. #if defined (WORDS_BIGENDIAN)
  1897.       swap = 0;
  1898. #else
  1899.       swap = 1;
  1900. #endif
  1901.     }
  1902.   else
  1903.     {
  1904.       if (! quiet)
  1905.     error ("load: can't read binary file");
  1906.       return -1;
  1907.     }
  1908.     
  1909.   char tmp = 0;
  1910.   is.read (&tmp, 1);
  1911.  
  1912.   flt_fmt = get_floating_point_format (tmp);
  1913.   if (flt_fmt == LS_UNKNOWN_FLT_FMT)
  1914.     {
  1915.       if (! quiet)
  1916.         error ("load: unrecognized binary format!");
  1917.       return -1;
  1918.     }
  1919.  
  1920.   return 0;
  1921. }
  1922.  
  1923. static load_save_format
  1924. get_file_format (const char *fname, const char *orig_fname)
  1925. {
  1926.   load_save_format retval = LS_UNKNOWN;
  1927.  
  1928.   ifstream file (fname);
  1929.  
  1930.   if (! file)
  1931.     {
  1932.       error ("load: couldn't open input file `%s'", orig_fname);
  1933.       return retval;
  1934.     }
  1935.  
  1936.   int swap;
  1937.   floating_point_format flt_fmt = LS_UNKNOWN_FLT_FMT;
  1938.  
  1939.   if (read_binary_file_header (file, swap, flt_fmt, 1) == 0)
  1940.     retval = LS_BINARY;
  1941.   else
  1942.     {
  1943.       file.seekg (0, ios::beg);
  1944.  
  1945.       FOUR_BYTE_INT mopt, nr, nc, imag, len;
  1946.       int swap;
  1947.  
  1948.       if (read_mat_file_header (file, swap, mopt, nr, nc, imag, len, 1) == 0)
  1949.     retval = LS_MAT_BINARY;
  1950.       else
  1951.     {
  1952.       file.seekg (0, ios::beg);
  1953.  
  1954.       char *tmp = extract_keyword (file, "name");
  1955.       if (tmp)
  1956.         retval = LS_ASCII;
  1957.  
  1958.       delete [] tmp;
  1959.     }
  1960.     }
  1961.  
  1962.   file.close ();
  1963.  
  1964.   if (retval == LS_UNKNOWN)
  1965.     error ("load: unable to determine file format for `%s'", orig_fname);
  1966.  
  1967.   return retval;
  1968. }
  1969.  
  1970. static Octave_object
  1971. do_load (istream& stream, const char *orig_fname, int force,
  1972.      load_save_format format, floating_point_format flt_fmt,
  1973.      int list_only, int swap, int verbose, char **argv,
  1974.      int argc, int nargout)
  1975. {
  1976.   Octave_object retval;
  1977.  
  1978.   ostrstream output_buf;
  1979.   int count = 0;
  1980.   for (;;)
  1981.     {
  1982.       int global = 0;
  1983.       tree_constant tc;
  1984.  
  1985.       char *name = 0;
  1986.       char *doc = 0;
  1987.  
  1988.       switch (format)
  1989.     {
  1990.     case LS_ASCII:
  1991.       name = read_ascii_data (stream, orig_fname, global, tc);
  1992.       break;
  1993.  
  1994.     case LS_BINARY:
  1995.       name = read_binary_data (stream, swap, flt_fmt, orig_fname,
  1996.                    global, tc, doc);
  1997.       break;
  1998.  
  1999.     case LS_MAT_BINARY:
  2000.       name = read_mat_binary_data (stream, orig_fname, tc);
  2001.       break;
  2002.  
  2003.     default:
  2004.       gripe_unrecognized_data_fmt ("load");
  2005.       break;
  2006.     }
  2007.  
  2008.       if (error_state || stream.eof () || ! name)
  2009.     {
  2010.       delete [] name;
  2011.       delete [] doc;
  2012.       break;
  2013.     }
  2014.       else if (! error_state && name)
  2015.     {
  2016.       if (tc.is_defined ())
  2017.         {
  2018.           if (argc == 0 || matches_patterns (argv, argc, name))
  2019.         {
  2020.           count++;
  2021.           if (list_only)
  2022.             {
  2023.               if (verbose)
  2024.             {
  2025.               if (count == 1)
  2026.                 output_buf
  2027.                   << "type               rows   cols   name\n"
  2028.                   << "====               ====   ====   ====\n";
  2029.  
  2030.               output_buf.form ("%-16s", tc.type_as_string ());
  2031.               output_buf.form ("%7d", tc.rows ());
  2032.               output_buf.form ("%7d", tc.columns ());
  2033.               output_buf << "   ";
  2034.             }
  2035.               output_buf << name << "\n";
  2036.             }
  2037.           else
  2038.             {
  2039.               install_loaded_variable (force, name, tc, global, doc);
  2040.             }
  2041.         }
  2042.         }
  2043.       else
  2044.         error ("load: unable to load variable `%s'", name);
  2045.     }
  2046.       else
  2047.     {
  2048.       if (count == 0)
  2049.         error ("load: are you sure `%s' is an Octave data file?",
  2050.            orig_fname);
  2051.  
  2052.       delete [] name;
  2053.       delete [] doc;
  2054.       break;
  2055.     }
  2056.  
  2057.       delete [] name;
  2058.       delete [] doc;
  2059.     }
  2060.  
  2061.   if (list_only && count)
  2062.     {
  2063.       if (nargout > 0)
  2064.     {
  2065.       output_buf << ends;
  2066.       char *msg = output_buf.str ();
  2067.       retval = msg;
  2068.       delete [] msg;
  2069.     }
  2070.       else
  2071.     maybe_page_output (output_buf);
  2072.     }
  2073.  
  2074.   return retval;
  2075. }
  2076.  
  2077. DEFUN_TEXT ("load", Fload, Sload, -1, 1,
  2078.   "load [-force] [-ascii] [-binary] [-mat-binary] file [pattern ...]\n\
  2079. \n\
  2080. Load variables from a file.\n\
  2081. \n\
  2082. If no argument is supplied to select a format, load tries to read the
  2083. named file as an Octave binary, then as a .mat file, and then as an
  2084. Octave text file.\n\
  2085. \n\
  2086. If the option -force is given, variables with the same names as those
  2087. found in the file will be replaced with the values read from the file.")
  2088. {
  2089.   Octave_object retval;
  2090.  
  2091.   DEFINE_ARGV ("load");
  2092.  
  2093.   argc--;
  2094.   argv++;
  2095.  
  2096.   int force = 0;
  2097.  
  2098. // It isn't necessary to have the default load format stored in a user
  2099. // preference variable since we can determine the type of file as we
  2100. // are reading.
  2101.  
  2102.   load_save_format format = LS_UNKNOWN;
  2103.  
  2104.   int list_only = 0;
  2105.   int verbose = 0;
  2106.  
  2107.   while (argc > 0)
  2108.     {
  2109.       if (strcmp (*argv, "-force") == 0 || strcmp (*argv, "-f") == 0)
  2110.     {
  2111.       force++;
  2112.       argc--;
  2113.       argv++;
  2114.     }
  2115.       else if (strcmp (*argv, "-list") == 0 || strcmp (*argv, "-l") == 0)
  2116.     {
  2117.       list_only = 1;
  2118.       argc--;
  2119.       argv++;
  2120.     }
  2121.       else if (strcmp (*argv, "-verbose") == 0 || strcmp (*argv, "-v") == 0)
  2122.     {
  2123.       verbose = 1;
  2124.       argc--;
  2125.       argv++;
  2126.     }
  2127.       else if (strcmp (*argv, "-ascii") == 0 || strcmp (*argv, "-a") == 0)
  2128.     {
  2129.       format = LS_ASCII;
  2130.       argc--;
  2131.       argv++;
  2132.     }
  2133.       else if (strcmp (*argv, "-binary") == 0 || strcmp (*argv, "-b") == 0)
  2134.     {
  2135.       format = LS_BINARY;
  2136.       argc--;
  2137.       argv++;
  2138.     }
  2139.       else if (strcmp (*argv, "-mat-binary") == 0 || strcmp (*argv, "-m") == 0)
  2140.     {
  2141.       format = LS_MAT_BINARY;
  2142.       argc--;
  2143.       argv++;
  2144.     }
  2145.       else
  2146.     break;
  2147.     }
  2148.  
  2149.   if (argc < 1)
  2150.     {
  2151.       error ("load: you must specify a single file to read");
  2152.       DELETE_ARGV;
  2153.       return retval;
  2154.     }
  2155.  
  2156.   char *orig_fname = *argv;
  2157.  
  2158.   floating_point_format flt_fmt = LS_UNKNOWN_FLT_FMT;
  2159.  
  2160.   int swap = 0;
  2161.  
  2162.   if (strcmp (*argv, "-") == 0)
  2163.     {
  2164.       argc--;
  2165.       argv++;
  2166.  
  2167.       if (format != LS_UNKNOWN)
  2168.     {
  2169. // XXX FIXME XXX -- if we have already seen EOF on a previous call,
  2170. // how do we fix up the state of cin so that we can get additional
  2171. // input?  I'm afraid that we can't fix this using cin only.
  2172.  
  2173.       retval = do_load (cin, orig_fname, force, format, flt_fmt,
  2174.                 list_only, swap, verbose, argv, argc,
  2175.                 nargout);
  2176.     }
  2177.       else
  2178.     error ("load: must specify file format if reading from stdin");
  2179.     }
  2180.   else
  2181.     {
  2182.       char *fname = tilde_expand (*argv);
  2183.  
  2184.       if (format == LS_UNKNOWN)
  2185.     format = get_file_format (fname, orig_fname);
  2186.  
  2187.       if (format != LS_UNKNOWN)
  2188.     {
  2189.       argv++;
  2190.       argc--;
  2191.  
  2192.       unsigned mode = ios::in;
  2193.       if (format == LS_BINARY || format == LS_MAT_BINARY)
  2194.         mode |= ios::bin;
  2195.  
  2196.       ifstream file (fname, mode);
  2197.  
  2198.       if (file)
  2199.         {
  2200.           if (format == LS_BINARY)
  2201.         {
  2202.           if (read_binary_file_header (file, swap, flt_fmt) < 0)
  2203.             {
  2204.               file.close ();
  2205.               DELETE_ARGV;
  2206.               return retval;
  2207.             }
  2208.         }
  2209.  
  2210.           retval = do_load (file, orig_fname, force, format,
  2211.                 flt_fmt, list_only, swap, verbose,
  2212.                 argv, argc, nargout);
  2213.  
  2214.           file.close ();
  2215.         }
  2216.       else
  2217.         error ("load: couldn't open input file `%s'", orig_fname);
  2218.     }
  2219.     }
  2220.  
  2221.   DELETE_ARGV;
  2222.  
  2223.   return retval;
  2224. }
  2225.  
  2226. // Return nonzero if PATTERN has any special globbing chars in it.
  2227.  
  2228. static int
  2229. glob_pattern_p (char *pattern)
  2230. {
  2231.   char *p = pattern;
  2232.   char c;
  2233.   int open = 0;
  2234.  
  2235.   while ((c = *p++) != '\0')
  2236.     {
  2237.       switch (c)
  2238.     {
  2239.     case '?':
  2240.     case '*':
  2241.       return 1;
  2242.  
  2243.     case '[':    // Only accept an open brace if there is a close
  2244.       open++;    // brace to match it.  Bracket expressions must be
  2245.       continue;    // complete, according to Posix.2
  2246.  
  2247.     case ']':
  2248.       if (open)
  2249.         return 1;
  2250.       continue;
  2251.       
  2252.     case '\\':
  2253.       if (*p++ == '\0')
  2254.         return 0;
  2255.  
  2256.     default:
  2257.       continue;
  2258.     }
  2259.     }
  2260.  
  2261.   return 0;
  2262. }
  2263.  
  2264. // MAX_VAL and MIN_VAL are assumed to have integral values even though
  2265. // they are stored in doubles.
  2266.  
  2267. static save_type
  2268. get_save_type (double max_val, double min_val)
  2269. {
  2270.   save_type st = LS_DOUBLE;
  2271.  
  2272.   if (max_val < 256 && min_val > -1)
  2273.     st = LS_U_CHAR;
  2274.   else if (max_val < 65536 && min_val > -1)
  2275.     st = LS_U_SHORT;
  2276.   else if (max_val < 4294967295 && min_val > -1)
  2277.     st = LS_U_INT;
  2278.   else if (max_val < 128 && min_val >= -128)
  2279.     st = LS_CHAR;
  2280.   else if (max_val < 32768 && min_val >= -32768)
  2281.     st = LS_SHORT;
  2282.   else if (max_val < 2147483648 && min_val > -2147483648)
  2283.     st = LS_INT;
  2284.  
  2285.   return st;
  2286. }
  2287.  
  2288. // Save the data from TC along with the corresponding NAME, help
  2289. // string DOC, and global flag MARK_AS_GLOBAL on stream OS in the
  2290. // binary format described above for load_binary_data.
  2291.  
  2292. static int
  2293. save_binary_data (ostream& os, const tree_constant& tc, char *name,
  2294.           char *doc, int mark_as_global, int save_as_floats) 
  2295. {
  2296.   int fail = 0;
  2297.  
  2298.   FOUR_BYTE_INT name_len = 0;
  2299.   if (name)
  2300.     name_len = strlen (name);
  2301.  
  2302.   os.write (&name_len, 4);
  2303.   os.write (name, name_len);
  2304.  
  2305.   FOUR_BYTE_INT doc_len = 0;
  2306.   if (doc)
  2307.     doc_len = strlen (doc);
  2308.  
  2309.   os.write (&doc_len, 4);
  2310.   os.write (doc, doc_len);
  2311.  
  2312.   char tmp;
  2313.  
  2314.   tmp = mark_as_global;
  2315.   os.write (&tmp, 1);
  2316.  
  2317.   if (tc.is_real_scalar ())
  2318.     {
  2319.       tmp = 1;
  2320.       os.write (&tmp, 1);
  2321.       tmp = (char) LS_DOUBLE;
  2322.       os.write (&tmp, 1);
  2323.       double tmp = tc.double_value ();
  2324.       os.write (&tmp, 8);
  2325.     }
  2326.   else if (tc.is_real_matrix ())
  2327.     {
  2328.       tmp = 2;
  2329.       os.write (&tmp, 1);
  2330.       Matrix m = tc.matrix_value ();
  2331.       FOUR_BYTE_INT nr = m.rows ();
  2332.       FOUR_BYTE_INT nc = m.columns ();
  2333.       os.write (&nr, 4);
  2334.       os.write (&nc, 4);
  2335.       int len = nr * nc;
  2336.       save_type st = LS_DOUBLE;
  2337.       if (save_as_floats)
  2338.     {
  2339.       if (too_large_for_float (m))
  2340.         {
  2341.           warning ("save: some values too large to save as floats --");
  2342.           warning ("save: saving as doubles instead");
  2343.         }
  2344.       else
  2345.         st = LS_FLOAT;
  2346.     }
  2347.       else if (len > 8192) // XXX FIXME XXX -- make this configurable.
  2348.     {
  2349.       double max_val, min_val;
  2350.       if (all_parts_int (m, max_val, min_val))
  2351.         st = get_save_type (max_val, min_val);
  2352.     }
  2353.       const double *mtmp = m.data ();
  2354.       write_doubles (os, mtmp, st, len);
  2355.     }
  2356.   else if (tc.is_complex_scalar ())
  2357.     {
  2358.       tmp = 3;
  2359.       os.write (&tmp, 1);
  2360.       tmp = (char) LS_DOUBLE;
  2361.       os.write (&tmp, 1);
  2362.       Complex tmp = tc.complex_value ();
  2363.       os.write (&tmp, 16);
  2364.     }
  2365.   else if (tc.is_complex_matrix ())
  2366.     {
  2367.       tmp = 4;
  2368.       os.write (&tmp, 1);
  2369.       ComplexMatrix m = tc.complex_matrix_value ();
  2370.       FOUR_BYTE_INT nr = m.rows ();
  2371.       FOUR_BYTE_INT nc = m.columns ();
  2372.       os.write (&nr, 4);
  2373.       os.write (&nc, 4);
  2374.       int len = nr * nc;
  2375.       save_type st = LS_DOUBLE;
  2376.       if (save_as_floats)
  2377.     {
  2378.       if (too_large_for_float (m))
  2379.         {
  2380.           warning ("save: some values too large to save as floats --");
  2381.           warning ("save: saving as doubles instead");
  2382.         }
  2383.       else
  2384.         st = LS_FLOAT;
  2385.     }
  2386.       else if (len > 4096) // XXX FIXME XXX -- make this configurable.
  2387.     {
  2388.       double max_val, min_val;
  2389.       if (all_parts_int (m, max_val, min_val))
  2390.         st = get_save_type (max_val, min_val);
  2391.     }
  2392.       const Complex *mtmp = m.data ();
  2393.       write_doubles (os, (const double *) mtmp, st, 2*len);
  2394.     }
  2395.   else if (tc.is_string ())
  2396.     {
  2397.       tmp = 5;
  2398.       os.write (&tmp, 1);
  2399.       int nr = tc.rows ();
  2400.       int nc = tc.columns ();
  2401.       FOUR_BYTE_INT len = nr * nc;
  2402.       os.write (&len, 4);
  2403.       char *s = tc.string_value ();
  2404.       os.write (s, len);
  2405.     }
  2406.   else if (tc.is_range ())
  2407.     {
  2408.       tmp = 6;
  2409.       os.write (&tmp, 1);
  2410.       tmp = (char) LS_DOUBLE;
  2411.       os.write (&tmp, 1);
  2412.       Range r = tc.range_value ();
  2413.       double bas = r.base ();
  2414.       double lim = r.limit ();
  2415.       double inc = r.inc ();
  2416.       os.write (&bas, 8);
  2417.       os.write (&lim, 8);
  2418.       os.write (&inc, 8);
  2419.     }
  2420.   else
  2421.     {
  2422.       gripe_wrong_type_arg ("save", tc);
  2423.       fail = 1;
  2424.     }
  2425.  
  2426.   return (os && ! fail);
  2427. }
  2428.  
  2429. // Save the data from TC along with the corresponding NAME on stream OS 
  2430. // in the MatLab binary format.
  2431.  
  2432. static int
  2433. save_mat_binary_data (ostream& os, const tree_constant& tc, char *name) 
  2434. {
  2435.   int fail = 0;
  2436.  
  2437.   FOUR_BYTE_INT mopt = 0;
  2438.  
  2439.   mopt += tc.is_string () ? 1 : 0;
  2440.   mopt += 1000 * get_floating_point_format (NATIVE_FLOAT_FORMAT);
  2441.  
  2442.   os.write (&mopt, 4);
  2443.   
  2444.   FOUR_BYTE_INT nr = tc.rows ();
  2445.   os.write (&nr, 4);
  2446.  
  2447.   FOUR_BYTE_INT nc = tc.columns ();
  2448.   os.write (&nc, 4);
  2449.  
  2450.   int len = nr * nc;
  2451.  
  2452.   FOUR_BYTE_INT imag = tc.is_complex_type () ? 1 : 0;
  2453.   os.write (&imag, 4);
  2454.  
  2455.   FOUR_BYTE_INT name_len = name ? strlen (name) + 1 : 0;
  2456.  
  2457.   os.write (&name_len, 4);
  2458.   os.write (name, name_len);
  2459.  
  2460.   if (tc.is_real_scalar ())
  2461.     {
  2462.       double tmp = tc.double_value ();
  2463.       os.write (&tmp, 8);
  2464.     }
  2465.   else if (tc.is_real_matrix ())
  2466.     {
  2467.       Matrix m = tc.matrix_value ();
  2468.       os.write (m.data (), 8 * len);
  2469.     }
  2470.   else if (tc.is_complex_scalar ())
  2471.     {
  2472.       Complex tmp = tc.complex_value ();
  2473.       os.write (&tmp, 16);
  2474.     }
  2475.   else if (tc.is_complex_matrix ())
  2476.     {
  2477.       ComplexMatrix m_cmplx = tc.complex_matrix_value ();
  2478.       Matrix m = ::real(m_cmplx);
  2479.       os.write (m.data (), 8 * len);
  2480.       m = ::imag(m_cmplx);
  2481.       os.write (m.data (), 8 * len);
  2482.     }
  2483.   else if (tc.is_string ())
  2484.     {
  2485.       begin_unwind_frame ("save_mat_binary_data");
  2486.       unwind_protect_int (user_pref.implicit_str_to_num_ok);
  2487.       user_pref.implicit_str_to_num_ok = 1;
  2488.       Matrix m = tc.matrix_value ();
  2489.       os.write (m.data (), 8 * len);
  2490.       run_unwind_frame ("save_mat_binary_data");
  2491.     }
  2492.   else if (tc.is_range ())
  2493.     {
  2494.       Range r = tc.range_value ();
  2495.       double base = r.base ();
  2496.       double inc = r.inc ();
  2497.       int nel = r.nelem ();
  2498.       for (int i = 0; i < nel; i++)
  2499.     {
  2500.       double x = base + i * inc;
  2501.       os.write (&x, 8);
  2502.     }
  2503.     }
  2504.   else
  2505.     {
  2506.       gripe_wrong_type_arg ("save", tc);
  2507.       fail = 1;
  2508.     }
  2509.  
  2510.   return (os && ! fail);
  2511. }
  2512.  
  2513. static void
  2514. ascii_save_type (ostream& os, char *type, int mark_as_global)
  2515. {
  2516.   if (mark_as_global)
  2517.     os << "# type: global ";
  2518.   else
  2519.     os << "# type: ";
  2520.  
  2521.   os << type << "\n";
  2522. }
  2523.  
  2524. static Matrix
  2525. strip_infnan (const Matrix& m)
  2526. {
  2527.   int nr = m.rows ();
  2528.   int nc = m.columns ();
  2529.  
  2530.   Matrix retval (nr, nc);
  2531.  
  2532.   int k = 0;
  2533.   for (int i = 0; i < nr; i++)
  2534.     {
  2535.       for (int j = 0; j < nc; j++)
  2536.     {
  2537.       double d = m.elem (i, j);
  2538.       if (xisnan (d))
  2539.         goto next_row;
  2540.       else
  2541.         retval.elem (k, j) = xisinf (d) ? (d > 0 ? OCT_RBV : -OCT_RBV) : d;
  2542.     }
  2543.       k++;
  2544.  
  2545.     next_row:
  2546.       continue;
  2547.     }
  2548.  
  2549.   if (k > 0)
  2550.     retval.resize (k, nc);
  2551.  
  2552.   return retval;
  2553. }
  2554.  
  2555. static ComplexMatrix
  2556. strip_infnan (const ComplexMatrix& m)
  2557. {
  2558.   int nr = m.rows ();
  2559.   int nc = m.columns ();
  2560.  
  2561.   ComplexMatrix retval (nr, nc);
  2562.  
  2563.   int k = 0;
  2564.   for (int i = 0; i < nr; i++)
  2565.     {
  2566.       for (int j = 0; j < nc; j++)
  2567.     {
  2568.       Complex c = m.elem (i, j);
  2569.       if (xisnan (c))
  2570.         goto next_row;
  2571.       else
  2572.         {
  2573.           double re = real (c);
  2574.           double im = imag (c);
  2575.  
  2576.           re = xisinf (re) ? (re > 0 ? OCT_RBV : -OCT_RBV) : re;
  2577.           im = xisinf (im) ? (im > 0 ? OCT_RBV : -OCT_RBV) : im;
  2578.  
  2579.           retval.elem (k, j) = Complex (re, im);
  2580.         }
  2581.     }
  2582.       k++;
  2583.  
  2584.     next_row:
  2585.       continue;
  2586.     }
  2587.  
  2588.   if (k > 0)
  2589.     retval.resize (k, nc);
  2590.  
  2591.   return retval;
  2592. }
  2593.  
  2594. // Save the data from TC along with the corresponding NAME, and global
  2595. // flag MARK_AS_GLOBAL on stream OS in the plain text format described
  2596. // above for load_ascii_data.  If NAME is null, the name: line is not
  2597. // generated.  PRECISION specifies the number of decimal digits to print. 
  2598. // If STRIP_NAN_AND_INF is nonzero, rows containing NaNs are deleted,
  2599. // and Infinite values are converted to +/-OCT_RBV (A Real Big Value,
  2600. // but not so big that gnuplot can't handle it when trying to compute
  2601. // axis ranges, etc.).
  2602. //
  2603. // Assumes ranges and strings cannot contain Inf or NaN values.
  2604. //
  2605. // Returns 1 for success and 0 for failure.
  2606.  
  2607. // XXX FIXME XXX -- should probably write the help string here too.
  2608.  
  2609. int
  2610. save_ascii_data (ostream& os, const tree_constant& tc,
  2611.          char *name, int strip_nan_and_inf,
  2612.          int mark_as_global, int precision) 
  2613. {
  2614.   int success = 1;
  2615.  
  2616.   if (! precision)
  2617.     precision = user_pref.save_precision;
  2618.  
  2619.   if (name)
  2620.     os << "# name: " << name << "\n";
  2621.  
  2622.   long old_precision = os.precision ();
  2623.   os.precision (precision);
  2624.  
  2625.   if (tc.is_real_scalar ())
  2626.     {
  2627.       ascii_save_type (os, "scalar", mark_as_global);
  2628.  
  2629.       double d = tc.double_value ();
  2630.       if (strip_nan_and_inf)
  2631.     {
  2632.       if (xisnan (d))
  2633.         {
  2634.           error ("only value to plot is NaN");
  2635.           success = 0;
  2636.         }
  2637.       else
  2638.         {
  2639.           d = xisinf (d) ? (d > 0 ? OCT_RBV : -OCT_RBV) : d;
  2640.           os << d << "\n";
  2641.         }
  2642.     }
  2643.       else
  2644.     os << d << "\n";
  2645.     }
  2646.   else if (tc.is_real_matrix ())
  2647.     {
  2648.       ascii_save_type (os, "matrix", mark_as_global);
  2649.       os << "# rows: " << tc.rows () << "\n"
  2650.      << "# columns: " << tc.columns () << "\n";
  2651.  
  2652.       Matrix tmp = tc.matrix_value ();
  2653.       if (strip_nan_and_inf)
  2654.     tmp = strip_infnan (tmp);
  2655.  
  2656.       os << tmp;
  2657.     }
  2658.   else if (tc.is_complex_scalar ())
  2659.     {
  2660.       ascii_save_type (os, "complex scalar", mark_as_global);
  2661.  
  2662.       Complex c = tc.complex_value ();
  2663.       if (strip_nan_and_inf)
  2664.     {
  2665.       if (xisnan (c))
  2666.         {
  2667.           error ("only value to plot is NaN");
  2668.           success = 0;
  2669.         }
  2670.       else
  2671.         {
  2672.           double re = real (c);
  2673.           double im = imag (c);
  2674.  
  2675.           re = xisinf (re) ? (re > 0 ? OCT_RBV : -OCT_RBV) : re;
  2676.           im = xisinf (im) ? (im > 0 ? OCT_RBV : -OCT_RBV) : im;
  2677.  
  2678.           c = Complex (re, im);
  2679.  
  2680.           os << c << "\n";
  2681.         }
  2682.     }
  2683.       else
  2684.     os << c << "\n";
  2685.     }
  2686.   else if (tc.is_complex_matrix ())
  2687.     {
  2688.       ascii_save_type (os, "complex matrix", mark_as_global);
  2689.       os << "# rows: " << tc.rows () << "\n"
  2690.      << "# columns: " << tc.columns () << "\n";
  2691.  
  2692.       ComplexMatrix tmp = tc.complex_matrix_value ();
  2693.       if (strip_nan_and_inf)
  2694.     tmp = strip_infnan (tmp);
  2695.  
  2696.       os << tmp;
  2697.     }
  2698.   else if (tc.is_string ())
  2699.     {
  2700.       ascii_save_type (os, "string", mark_as_global);
  2701.       char *tmp = tc.string_value ();
  2702.       os << "# length: " << strlen (tmp) << "\n"
  2703.      << tmp << "\n";
  2704.     }
  2705.   else if (tc.is_range ())
  2706.     {
  2707.       ascii_save_type (os, "range", mark_as_global);
  2708.       Range tmp = tc.range_value ();
  2709.       os << "# base, limit, increment\n"
  2710.      << tmp.base () << " "
  2711.      << tmp.limit () << " "
  2712.      << tmp.inc () << "\n";
  2713.     }
  2714.   else
  2715.     {
  2716.       gripe_wrong_type_arg ("save", tc);
  2717.       success = 0;
  2718.     }
  2719.  
  2720.   os.precision (old_precision);
  2721.  
  2722.   return (os && success);
  2723. }
  2724.  
  2725. // Save the info from sr on stream os in the format specified by fmt.
  2726.  
  2727. static void
  2728. do_save (ostream& os, symbol_record *sr, load_save_format fmt,
  2729.      int save_as_floats)
  2730. {
  2731.   if (! sr->is_variable ())
  2732.     {
  2733.       error ("save: can only save variables, not functions");
  2734.       return;
  2735.     }
  2736.  
  2737.   char *name = sr->name ();
  2738.   char *help = sr->help ();
  2739.   int global = sr->is_linked_to_global ();
  2740.   tree_constant tc = *((tree_constant *) sr->def ());
  2741.  
  2742.   if (! name || ! tc.is_defined ())
  2743.     return;
  2744.  
  2745.   switch (fmt)
  2746.     {
  2747.     case LS_ASCII:
  2748.       save_ascii_data (os, tc, name, 0, global);
  2749.       break;
  2750.  
  2751.     case LS_BINARY:
  2752.       save_binary_data (os, tc, name, help, global, save_as_floats);
  2753.       break;
  2754.  
  2755.     case LS_MAT_BINARY:
  2756.       save_mat_binary_data (os, tc, name);
  2757.       break;
  2758.  
  2759.     default:
  2760.       gripe_unrecognized_data_fmt ("save");
  2761.       break;
  2762.     }
  2763. }
  2764.  
  2765. // Save variables with names matching PATTERN on stream OS in the
  2766. // format specified by FMT.  If SAVE_BUILTINS is nonzero, also save
  2767. // builtin variables with names that match PATTERN.
  2768.  
  2769. static int
  2770. save_vars (ostream& os, char *pattern, int save_builtins,
  2771.        load_save_format fmt, int save_as_floats)
  2772. {
  2773.   int count;
  2774.  
  2775.   symbol_record **vars = curr_sym_tab->glob
  2776.     (count, pattern, symbol_def::USER_VARIABLE, SYMTAB_ALL_SCOPES);
  2777.  
  2778.   int saved = count;
  2779.  
  2780.   int i;
  2781.  
  2782.   for (i = 0; i < count; i++)
  2783.     {
  2784.       do_save (os, vars[i], fmt, save_as_floats);
  2785.  
  2786.       if (error_state)
  2787.     break;
  2788.     }
  2789.  
  2790.   delete [] vars;
  2791.  
  2792.   if (! error_state && save_builtins)
  2793.     {
  2794.       symbol_record **vars = global_sym_tab->glob
  2795.     (count, pattern, symbol_def::BUILTIN_VARIABLE, SYMTAB_ALL_SCOPES);
  2796.  
  2797.       saved += count;
  2798.  
  2799.       for (i = 0; i < count; i++)
  2800.     {
  2801.       do_save (os, vars[i], fmt, save_as_floats);
  2802.  
  2803.       if (error_state)
  2804.         break;
  2805.     }
  2806.  
  2807.       delete [] vars;
  2808.     }
  2809.  
  2810.   return saved;
  2811. }
  2812.  
  2813. static load_save_format
  2814. get_default_save_format (void)
  2815. {
  2816.   load_save_format retval = LS_ASCII;
  2817.  
  2818.   char *fmt = user_pref.default_save_format;
  2819.  
  2820.   if (strcasecmp (fmt, "binary") == 0)
  2821.     retval = LS_BINARY;
  2822.   else if (strcasecmp (fmt, "mat-binary") == 0
  2823.        || strcasecmp (fmt, "mat_binary") == 0)
  2824.     retval = LS_MAT_BINARY;
  2825.       
  2826.   return retval;
  2827. }
  2828.  
  2829. static void
  2830. write_binary_header (ostream& stream, load_save_format format)
  2831. {
  2832.   if (format == LS_BINARY)
  2833.     {
  2834. #if defined (WORDS_BIGENDIAN)
  2835.       stream << "Octave-1-B";
  2836. #else
  2837.       stream << "Octave-1-L";
  2838. #endif
  2839.  
  2840.       char tmp = (char) NATIVE_FLOAT_FORMAT;
  2841.       stream.write (&tmp, 1);
  2842.     }
  2843. }
  2844.  
  2845. static void
  2846. save_vars (char **argv, int argc, ostream& os, int save_builtins,
  2847.        load_save_format fmt, int save_as_floats)
  2848. {
  2849.   write_binary_header (os, fmt);
  2850.  
  2851.   if (argc == 0)
  2852.     {
  2853.       save_vars (os, "*", save_builtins, fmt, save_as_floats);
  2854.     }
  2855.   else
  2856.     {
  2857.       while (argc-- > 0)
  2858.     {
  2859.       if (! save_vars (os, *argv, save_builtins, fmt, save_as_floats))
  2860.         {
  2861.           warning ("save: no such variable `%s'", *argv);
  2862.         }
  2863.  
  2864.       argv++;
  2865.     }
  2866.     }
  2867. }
  2868.  
  2869. DEFUN_TEXT ("save", Fsave, Ssave, -1, 1,
  2870.   "save [-ascii] [-binary] [-float-binary] [-mat-binary] \n\
  2871.      [-save-builtins] file [pattern ...]\n\
  2872. \n\
  2873. save variables in a file")
  2874. {
  2875.   Octave_object retval;
  2876.  
  2877.   DEFINE_ARGV ("save");
  2878.  
  2879.   argc--;
  2880.   argv++;
  2881.  
  2882. // Here is where we would get the default save format if it were
  2883. // stored in a user preference variable.
  2884.  
  2885.   int save_builtins = 0;
  2886.  
  2887.   int save_as_floats = 0;
  2888.  
  2889.   load_save_format format = get_default_save_format ();
  2890.  
  2891.   while (argc > 0)
  2892.     {
  2893.       if (strcmp (*argv, "-ascii") == 0 || strcmp (*argv, "-a") == 0)
  2894.     {
  2895.       format = LS_ASCII;
  2896.       argc--;
  2897.       argv++;
  2898.     }
  2899.       else if (strcmp (*argv, "-binary") == 0 || strcmp (*argv, "-b") == 0)
  2900.     {
  2901.       format = LS_BINARY;
  2902.       argc--;
  2903.       argv++;
  2904.     }
  2905.       else if (strcmp (*argv, "-mat-binary") == 0 || strcmp (*argv, "-m") == 0)
  2906.     {
  2907.       format = LS_MAT_BINARY;
  2908.       argc--;
  2909.       argv++;
  2910.     }
  2911.       else if (strcmp (*argv, "-float-binary") == 0
  2912.            || strcmp (*argv, "-f") == 0)
  2913.     {
  2914.       format = LS_BINARY;
  2915.       save_as_floats = 1;
  2916.       argc--;
  2917.       argv++;
  2918.     }
  2919.       else if (strcmp (*argv, "-save-builtins") == 0)
  2920.     {
  2921.       save_builtins = 1;
  2922.       argc--;
  2923.       argv++;
  2924.     }
  2925.       else
  2926.     break;
  2927.     }
  2928.  
  2929.   if (argc < 1)
  2930.     {
  2931.       print_usage ("save");
  2932.       DELETE_ARGV;
  2933.       return retval;
  2934.     }
  2935.  
  2936.   if (save_as_floats && format == LS_ASCII)
  2937.     {
  2938.       error ("save: cannot specify both -ascii and -float-binary");
  2939.       DELETE_ARGV;
  2940.       return retval;
  2941.     }
  2942.  
  2943.   if (strcmp (*argv, "-") == 0)
  2944.     {
  2945.       argc--;
  2946.       argv++;
  2947.  
  2948. // XXX FIXME XXX -- should things intended for the screen end up in a 
  2949. // tree_constant (string)?
  2950.  
  2951.       ostrstream buf;
  2952.  
  2953.       save_vars (argv, argc, buf, save_builtins, format,
  2954.          save_as_floats);
  2955.  
  2956.       maybe_page_output (buf);
  2957.     }
  2958.   else if (argc == 1 && glob_pattern_p (*argv)) // Guard against things
  2959.     {                        // like `save a*',
  2960.       print_usage ("save");            // which are probably
  2961.       DELETE_ARGV;                // mistakes...
  2962.       return retval;
  2963.     }
  2964.   else
  2965.     {
  2966.       char *fname = tilde_expand (*argv);
  2967.  
  2968.       argc--;
  2969.       argv++;
  2970.  
  2971.       unsigned mode = ios::out|ios::trunc;
  2972.       if (format == LS_BINARY || format == LS_MAT_BINARY)
  2973.     mode |= ios::bin;
  2974.  
  2975.       ofstream file (fname, mode);
  2976.  
  2977.       if (file)
  2978.     {
  2979.       save_vars (argv, argc, file, save_builtins, format,
  2980.              save_as_floats);
  2981.     }
  2982.       else
  2983.     {
  2984.       error ("save: couldn't open output file `%s'", *argv);
  2985.       DELETE_ARGV;
  2986.       return retval;
  2987.     }
  2988.     }
  2989.  
  2990.   DELETE_ARGV;
  2991.  
  2992.   return retval;
  2993. }
  2994.  
  2995. // Maybe this should be a static function in tree-plot.cc?
  2996.  
  2997. // If TC is matrix, save it on stream OS in a format useful for
  2998. // making a 3-dimensional plot with gnuplot.  If PARAMETRIC is
  2999. // nonzero, assume a parametric 3-dimensional plot will be generated.
  3000.  
  3001. int
  3002. save_three_d (ostream& os, const tree_constant& tc, int parametric)
  3003. {
  3004.   int fail = 0;
  3005.  
  3006.   int nr = tc.rows ();
  3007.   int nc = tc.columns ();
  3008.  
  3009.   if (tc.is_real_matrix ())
  3010.     {
  3011.       os << "# 3D data...\n"
  3012.      << "# type: matrix\n"
  3013.      << "# total rows: " << nr << "\n"
  3014.      << "# total columns: " << nc << "\n";
  3015.  
  3016.       if (parametric)
  3017.     {
  3018.       int extras = nc % 3;
  3019.       if (extras)
  3020.         warning ("ignoring last %d columns", extras);
  3021.  
  3022.       Matrix tmp = tc.matrix_value ();
  3023.       tmp = strip_infnan (tmp);
  3024.       nr = tmp.rows ();
  3025.  
  3026.       for (int i = 0; i < nc-extras; i += 3)
  3027.         {
  3028.           os << tmp.extract (0, i, nr-1, i+2);
  3029.           if (i+3 < nc-extras)
  3030.         os << "\n";
  3031.         }
  3032.     }
  3033.       else
  3034.     {
  3035.       Matrix tmp = tc.matrix_value ();
  3036.       tmp = strip_infnan (tmp);
  3037.       nr = tmp.rows ();
  3038.  
  3039.       for (int i = 0; i < nc; i++)
  3040.         {
  3041.           os << tmp.extract (0, i, nr-1, i);
  3042.           if (i+1 < nc)
  3043.         os << "\n";
  3044.         }
  3045.     }
  3046.     }
  3047.   else
  3048.     {
  3049.       ::error ("for now, I can only save real matrices in 3D format");
  3050.       fail = 1;
  3051.     }
  3052.  
  3053.   return (os && ! fail);
  3054. }
  3055.  
  3056. /*
  3057. ;;; Local Variables: ***
  3058. ;;; mode: C++ ***
  3059. ;;; page-delimiter: "^/\\*" ***
  3060. ;;; End: ***
  3061. */
  3062.