1% This example shows how one can save the values of slang variables to a file
2% and then load those values back in another instance of the program.
3%
4% The following code defines two public functions:
5%
6%    save_object (FILE, obj, ...);
7%    (obj,...) = load_object (FILE);
8%
9% For example,
10%     a = [1:20];
11%     b = 2.4;
12%     c = struct { d, e }; c.d = 2.7; c.e = "foobar";
13%     save_object ("foo.save", a, b, c);
14%
15% saves the values of the variables a, b, c to a file called "foo.save".
16% These values may be retrieved later, e.g., by another program instance
17% via:
18%     (a,b,c) = load_object ("foo.save");
19%
20% Caveats:
21%
22% 1. Not all object types are supported.  The ones supported include:
23%
24%     All integer types (Int_Type, Char_Type, Long_Type, ...)
25%     Float_Type, Double_Type
26%     String_Type, BString_Type
27%     Null_Type
28%
29%    as well as the container classes of the above objects:
30%     Struct_Type, Array_Type
31%
32% 2. The algorithm for saving Struct_Type is recursive.  This allows one to
33%    save a linked-list of Struct_Type objects.  However, due to the recursive
34%    nature of the algorithm and the interpreter's finite stack size, such
35%    linked-lists cannot be arbitrarily long.
36%
37% 3. Objects are saved in the native representation.  As such, the files are
38%    not portable across machine architectures.
39%
40% File Format:
41%
42% Each slang object is written to the file with the following format
43%   Data_Type            (integer)
44%   Length of Data Bytes (unsigned integer)
45%   Data Bytes
46%
47% Here, Data Bytes may specify other objects if the parent is a container
48% object.
49
50%_debug_info = 1;
51
52private variable Type_Map = Assoc_Type[Integer_Type, -1];
53private variable Write_Object_Funs = Assoc_Type[Ref_Type];
54private variable Read_Object_Funs = Assoc_Type[Ref_Type];
55
56!if (is_defined ("_Save_Object_Cache_Type"))
57typedef struct
58{
59   index
60}
61_Save_Object_Cache_Type;
62
63private variable Object_Cache;
64private variable Num_Cached;
65
66private define delete_cache ()
67{
68   Object_Cache = NULL;
69   Num_Cached = 0;
70}
71
72private define create_cache ()
73{
74   delete_cache ();
75}
76
77% If the object does not need cached, return the object.
78% If the object needs cached but does not exist in the cache, cache it and
79%   return it.
80% Otherwise, the object is in the cache, to return a _Save_Object_Cache_Type
81% representing the object.
82private define cache_object (obj)
83{
84   variable t = typeof (obj);
85
86   if ((t != Array_Type)
87       and (0 == is_struct_type (obj))
88       and (t != BString_Type))
89     {
90	%vmessage ("not caching %S (type %S)", obj, typeof (obj));
91	return obj;
92     }
93
94   variable n = Num_Cached;
95   variable c = Object_Cache;
96   while (n)
97     {
98	if (__is_same (c.obj, obj))
99	  {
100	     obj = @_Save_Object_Cache_Type;
101	     obj.index = n;
102	     return obj;
103	  }
104
105	c = c.next;
106	n--;
107     }
108
109   c = struct {obj, next};
110   c.obj = obj;
111   c.next = Object_Cache;
112   Object_Cache = c;
113   Num_Cached++;
114   %vmessage ("%S (type %S) added to cache", c.obj, typeof (c.obj));
115
116   return obj;
117}
118
119private define get_object_from_cache (index)
120{
121   variable depth = Num_Cached - index;
122   variable c = Object_Cache;
123   while (depth)
124     {
125	c = c.next;
126	depth--;
127     }
128   return c.obj;
129}
130
131private define get_type_id (type)
132{
133   variable id;
134   id = Type_Map[string (type)];
135   if (id == -1)
136     verror ("Object %S is not supported", type);
137   return id;
138}
139
140private define write_not_implemented (fp, object)
141{
142   () = fprintf (stderr, "write for object %S not implemented\n", typeof (object));
143   return 0;
144}
145
146private define do_fwrite (a, fp)
147{
148   %vmessage ("Writing %S", a);
149   variable n = fwrite (a, fp);
150   if (n == -1)
151     verror ("fwrite failed: %s", errno_string (errno));
152   return n;
153}
154
155private define do_fread (t, n, fp)
156{
157   variable b;
158   if (n != fread (&b, t, n, fp))
159     verror ("fread failed: %s", errno_string (errno));
160   %vmessage ("Read %S", b);
161   return b;
162}
163
164private define do_ftell (fp)
165{
166   variable pos = ftell (fp);
167   if (-1 == pos)
168     verror ("ftell failed: %s", errno_string (errno));
169   return pos;
170}
171
172private define do_fseek (fp, ofs, whence)
173{
174   if (-1 == fseek (fp, ofs, whence))
175     verror ("fseek failed: %s", errno_string (errno));
176}
177
178private define sizeof (t)
179{
180   variable size;
181
182   switch (t)
183     { case Char_Type or case UChar_Type: size = 1; }
184     { case Int16_Type or case UInt16_Type: size = 2; }
185     { case Int32_Type or case UInt32_Type: size = 4; }
186     { case Float_Type: size = 4; }
187     { case Double_Type: size = 8; }
188     {
189	verror ("sizeof (%S) not implemented", t);
190     }
191
192   return size;
193}
194
195private define write_numbers (fp, a)
196{
197   variable size = sizeof (_typeof (a));
198   variable num = do_fwrite (a, fp);
199   return num * size;
200}
201
202private define read_numbers (fp, t, nbytes)
203{
204   variable size = sizeof (t);
205   nbytes /= size;
206   return do_fread (t, nbytes, fp);
207}
208
209private define write_string (fp, a)
210{
211   return do_fwrite (a, fp);
212}
213
214private define read_string (fp, t, nbytes)
215{
216   return do_fread (BString_Type, nbytes, fp);
217}
218
219private define start_header (fp, id)
220{
221   variable len = write_numbers (fp, id);
222   variable pos = do_ftell (fp);
223   len += write_numbers (fp, 0);	       %  temporary
224
225   variable h = struct
226     {
227	pos, len
228     };
229   h.pos = pos;
230   h.len = len;
231
232   return h;
233}
234
235private define end_header (fp, h, num)
236{
237   do_fseek (fp, h.pos, SEEK_SET);
238   () = do_fwrite (num, fp);
239   do_fseek (fp, 0, SEEK_END);
240   return h.len + num;
241}
242
243private define id_to_datatype (id)
244{
245   variable keys, values;
246
247   keys = assoc_get_keys (Type_Map);
248   values = assoc_get_values (Type_Map);
249   variable i = where (values == id);
250   !if (length (i))
251     verror ("Corrupt file?  Unknown type-id (%d)", id);
252   return eval (keys[i][0]);
253}
254
255private define write_scalars (fp, a)
256{
257   variable id = get_type_id (typeof (a));
258   variable h = start_header (fp, id);
259   variable len = write_numbers (fp, a);
260   return end_header (fp, h, len);
261}
262
263private define read_null (fp, t, nbytes)
264{
265   return NULL;
266}
267
268private define write_null (fp, a)
269{
270   return 0;
271}
272
273private define write_object ();
274private define read_object ();
275
276% Array DataBytes: int num_dims, int dims[num_dims], type, Data...
277private define write_array (fp, a)
278{
279   variable dims, num_dims, data_type;
280   (dims, num_dims, data_type) = array_info (a);
281   variable len;
282   variable id = get_type_id (data_type);
283
284   len = write_numbers (fp, num_dims) + write_numbers (fp, dims)
285     + write_numbers (fp, id);
286
287   % For now allow numbers or strings
288   if (_typeof(a) == String_Type)
289     {
290	foreach (a)
291	  {
292	     variable elem = ();
293	     len += write_object (fp, elem);
294	  }
295
296	return len;
297     }
298
299   len += write_numbers (fp, a);
300
301   return len;
302}
303
304private define read_array (fp, type, nbytes)
305{
306   variable num_dims = do_fread (Int_Type, 1, fp);
307   variable dims = do_fread (Int_Type, num_dims, fp);
308   type = do_fread (Int_Type, 1, fp);
309   variable len;
310   len = 1;
311   foreach (dims)
312     len *= ();
313
314   type = id_to_datatype (type);
315
316   variable v;
317
318   if (type == String_Type)
319     {
320	v = String_Type [len];
321	_for (0,len-1,1)
322	  {
323	     variable i = ();
324	     v[i] = read_object (fp, NULL);
325	  }
326     }
327   else v = do_fread (type, len, fp);
328
329   reshape (v, dims);
330   return v;
331}
332
333% Data Bytes: int num_fields.  String-Object [num_fields], Values[num_fields]
334private define write_struct (fp, a)
335{
336   variable fields = get_struct_field_names (a);
337   variable len = write_numbers (fp, typecast (length (fields), Int_Type));
338   foreach (fields)
339     {
340	variable f = ();
341	len += write_object (fp, f);
342     }
343
344   foreach (fields)
345     {
346	f = ();
347	len += write_object (fp, get_struct_field (a, f));
348     }
349
350   return len;
351}
352
353private define read_struct (fp, type, nbytes)
354{
355   variable num_fields = do_fread (Int_Type, 1, fp);
356   variable fields = String_Type[num_fields];
357   variable i;
358   _for (0, num_fields-1, 1)
359     {
360	i = ();
361	fields[i] = read_object (fp, NULL);
362     }
363
364   variable s = @Struct_Type (fields);
365
366   %  make sure it is in the cache in case the fields refer to it.
367   if (type != _Save_Object_Cache_Type)
368     () = cache_object (s);
369
370   _for (0, num_fields-1, 1)
371     {
372	i = ();
373	set_struct_field (s, fields[i], read_object (fp, NULL));
374     }
375
376   return s;
377}
378
379% Data Bytes: int index
380private define write_cached_object (fp, a)
381{
382   return write_numbers (fp, a.index);
383}
384
385private define read_cached_object (fp, type, nbytes)
386{
387   variable index = read_numbers (fp, Int_Type, nbytes);
388   return get_object_from_cache (index);
389}
390
391private define add_type (t, w, r, id)
392{
393   t = string (t);
394   Type_Map[t] = id;
395   Write_Object_Funs[t] = w;
396   Read_Object_Funs [t] = r;
397}
398
399add_type (Char_Type,	&write_numbers,	&read_numbers,	1);
400add_type (UChar_Type,	&write_numbers,	&read_numbers,	2);
401add_type (Short_Type,	&write_numbers,	&read_numbers,	3);
402add_type (UShort_Type,	&write_numbers,	&read_numbers,	4);
403add_type (Integer_Type,	&write_numbers,	&read_numbers,	5);
404add_type (UInteger_Type,&write_numbers,	&read_numbers,	6);
405add_type (Long_Type,	&write_numbers,	&read_numbers,	7);
406add_type (ULong_Type,	&write_numbers,	&read_numbers,	8);
407add_type (Float_Type,	&write_numbers,	&read_numbers,	9);
408add_type (Double_Type,	&write_numbers,	&read_numbers,	10);
409add_type (String_Type,	&write_string,	&read_string,	11);
410add_type (BString_Type,	&write_string,	&read_string,	12);
411add_type (Struct_Type,	&write_struct,	&read_struct,	13);
412add_type (Array_Type,	&write_array,	&read_array,	14);
413add_type (Null_Type,	&write_null,	&read_null,	15);
414
415add_type (_Save_Object_Cache_Type, &write_cached_object, &read_cached_object, 1000);
416
417private define get_write_function (type)
418{
419   variable key = string (type);
420   if (assoc_key_exists (Write_Object_Funs, key))
421     return Write_Object_Funs[key];
422   verror ("No write method defined for %S", key);
423}
424
425private define get_read_function (type)
426{
427   variable key = string (type);
428   if (assoc_key_exists (Read_Object_Funs, key))
429     return Read_Object_Funs[key];
430   verror ("No read method defined for %S", key);
431}
432
433private define write_object (fp, a)
434{
435   a = cache_object (a);
436   variable id = get_type_id (typeof (a));
437
438   variable h = start_header (fp, id);
439   variable f = get_write_function (typeof (a));
440   variable num = (@f)(fp, a);
441   %vmessage ("Done Writing %S", a);
442   return end_header (fp, h, num);
443}
444
445private define read_object (fp, statusp)
446{
447   variable type, nbytes;
448   variable status = fread (&type, Integer_Type, 1, fp);
449   if (status == -1)
450     {
451	if (statusp == NULL)
452	  verror ("No more objects in file");
453
454	@statusp = 0;
455	return 0;
456     }
457
458   nbytes = do_fread (Integer_Type, 1, fp);
459   type = id_to_datatype (type);
460
461   variable f = get_read_function (type);
462   variable v = (@f)(fp, type, nbytes);
463
464   % Necessary because String_Type may get written as BString_Type
465   if (type != _Save_Object_Cache_Type)
466     {
467	v = typecast (v, type);
468	() = cache_object (v);
469     }
470
471   %vmessage ("Read %S", v);
472   if (statusp != NULL)
473     @statusp = 1;
474
475   return v;
476}
477
478public define save_object ()
479{
480   if (_NARGS < 2)
481     usage ("save_object (file, obj1, ...)");
482
483   variable objs = __pop_args (_NARGS - 1);
484   variable file = ();
485
486   variable fp = fopen (file, "w+");
487   if (fp == NULL)
488     verror ("Unable to open %s: %s", file, errno_string (errno));
489
490   create_cache ();
491
492   foreach (objs)
493     {
494	variable obj = ().value;
495	() = write_object (fp, obj);
496     }
497
498   delete_cache ();
499}
500
501public define load_object ()
502{
503   if (_NARGS != 1)
504     usage ("(var1,...) = load_object (filename);");
505   variable file = ();
506   variable fp = fopen (file, "r");
507   if (fp == NULL)
508     verror ("Unable to open %s: %s", file, errno_string (errno));
509
510   create_cache ();
511   forever
512     {
513	variable status;
514	variable obj = read_object (fp, &status);
515	if (status == 0)
516	  break;
517	obj;
518     }
519   delete_cache ();
520}
521
522#ifntrue
523% Regression test
524private define failed (s, a, b)
525{
526   vmessage ("Failed: %s: wrote: '%S', read '%S'\n", s, a, b);
527}
528
529private define test_eqs ();
530private define test_eqs (a, b)
531{
532   if ((typeof (a) != typeof (b))
533       or (_typeof (a) != _typeof (b)))
534     {
535	failed ("typeof", typeof(a), typeof(b));
536	verror ("foo");
537	return 0;
538     }
539
540   if (typeof (a) != Struct_Type)
541     {
542	if (length (a) != length (b))
543	  {
544	     failed ("test_eqs length", a, b);
545	     return 0;
546	  }
547
548	if (length (where (a != b)))
549	  {
550	     failed ("test_eqs", a, b);
551	     return 0;
552	  }
553	return 1;
554     }
555
556   variable fa, fb;
557   fa = get_struct_field_names (a);
558   fb = get_struct_field_names (b);
559
560   !if (test_eqs (fa, fb))
561     {
562	failed ("test_eqs: fa, fb");
563	return 0;
564     }
565
566   if (length (fa) != length (fb))
567     return 0;
568
569   foreach (fa)
570     {
571	variable name = ();
572	variable va, vb;
573	va = get_struct_field (a, name);
574	vb = get_struct_field (b, name);
575	if ((typeof (va) == Struct_Type)
576	    and (typeof (vb) == Struct_Type))
577	  {
578	     % void loop
579	     continue;
580	  }
581	!if (test_eqs (va, vb))
582	  return 0;
583     }
584
585   return 1;
586}
587
588private define test_save_object ()
589{
590   variable x0 = 1278;
591   variable x1 = 2.3;
592   variable x2 = "foo";
593   variable x3 = struct
594     {
595	a, b, c, d
596     };
597   variable x4 = [1:10];
598   variable x5 = ["a","b","c","d"];
599
600   x3.a = "foo";
601   x3.b = PI;
602   x3.c = [1:20];
603   x3.d = x3;
604
605   variable x6 = typecast ("foo", BString_Type);
606   variable x7 = x6;
607   save_object ("foo.sv", x0,x1,x2,x3,x4,x5,x6,x7);
608
609   variable y0,y1,y2,y3,y4,y5,y6,y7;
610
611   (y0,y1,y2,y3,y4,y5,y6,y7) = load_object ("foo.sv");
612
613   !if (test_eqs (x0, y0))
614     failed ("x0", x0, y0);
615   !if (test_eqs (x1, y1))
616     failed ("x1", x1, y1);
617   !if (test_eqs (x2, y2))
618     failed ("x2", x2, y2);
619
620   !if (test_eqs (x3, y3))
621     failed ("x3", x3, y3);
622
623   !if (test_eqs (x4, y4))
624     failed ("x4", x4, y4);
625   !if (test_eqs (x5, y5))
626     failed ("x5", x5, y5);
627
628   !if (test_eqs (x6, y6))
629     failed ("x5", x6, y6);
630   !if (__is_same (y6,y7))
631     failed ("__is_same(y6,y7)",y6,y7);
632
633   vmessage ("Regression Test Done");
634}
635
636test_save_object ();
637#endif
638