1 /* Part of XPCE --- The SWI-Prolog GUI toolkit
2
3 Author: Jan Wielemaker and Anjo Anjewierden
4 E-mail: jan@swi.psy.uva.nl
5 WWW: http://www.swi.psy.uva.nl/projects/xpce/
6 Copyright (c) 1985-2002, University of Amsterdam
7 All rights reserved.
8
9 Redistribution and use in source and binary forms, with or without
10 modification, are permitted provided that the following conditions
11 are met:
12
13 1. Redistributions of source code must retain the above copyright
14 notice, this list of conditions and the following disclaimer.
15
16 2. Redistributions in binary form must reproduce the above copyright
17 notice, this list of conditions and the following disclaimer in
18 the documentation and/or other materials provided with the
19 distribution.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32 POSSIBILITY OF SUCH DAMAGE.
33 */
34
35 #include <h/kernel.h>
36 #include <h/unix.h>
37
38 static Any loadNameObject(IOSTREAM *);
39 static int pceSlotsClass(Class);
40 static status checkConvertedObject(Any, ClassDef);
41 static Int storeClass(Class, FileObj);
42 static status storeExtensionsObject(Any obj, FileObj file);
43 static status storeIdObject(Any obj, Int id, FileObj file);
44 static status storeSlotsClass(Class class, FileObj file);
45 static status restoreClass(IOSTREAM *fd);
46 static int offsetVariable(Class class, Name name);
47
48 static int objects_saved;
49 static int classes_saved;
50 static int save_nesting; /* depth of saved object */
51
52 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
53 Binary saved state of PCE object (collection). File format:
54
55 <file> ::= <magic>
56 <version>
57 <object>
58 {'s' <object>} (= support objects)
59 {'n' <from> <slot> <to>} (= nil-references)
60 {'r' <from> <slot> {'R' <to>} 'x'} (= reference-chains)
61 'x'
62
63 <magic> ::= <string> (= SAVEMAGIC)
64 <version> ::= <word> (= SAVEVERSION)
65
66 <object> ::= ['C' <class_def>] (a Class slot definition)
67 'O'
68 <class_id>
69 <object_name>
70 {<extension>} 'x'
71 {<slot>} (times according to class def)
72 | 'd' (@default)
73 | 'n' (@nil)
74 | 'a' (@on)
75 | 'u' (@off)
76 | 'r' (@receiver)
77 | 'b' (@block)
78 | '1' (@arg1)
79 | '2' (@arg2)
80 | '3' (@arg3)
81 | '4' (@arg4)
82 | '5' (@arg5)
83 | '6' (@arg6)
84 | '7' (@arg7)
85 | '8' (@arg8)
86 | '9' (@arg9)
87 | '0' (@arg10)
88 | 'N' <string> (a name)
89 | 'S' <string> <string> (HACK: a lisp_symbol)
90 | 'I' <integer> (an integer)
91 | 'R' <object_name> (reference to saved object)
92 | 'A' <string> (reference to exernal object)
93 | 'D' <object> (Descriptive object)
94
95 <extension> ::= 'a' <Object> (Attribute sheet)
96 | 'c' <Object> (Constraint-list)
97 | 's' <Object> (SendMethod-list)
98 | 'g' <Object> (GetMethod-list)
99 | 'r' <Object> (Recogniser-list)
100 | 'h' <Object> (Hyper-list)
101
102 <object_name> ::= 'N' <string> (name as reference)
103 | 'I' <word> (integer as reference)
104 <abtract> ::= <slot>
105 <slot> ::= <object>
106
107 <class_def> ::= <class_name> <class_id>
108 <slots> (number of pce typed slots)
109 {<slot_name>} (<slots> times)
110 <class_name> ::= <string>
111 <class_id> ::= <word>
112 <slots> ::= <word>
113 <slot_name> ::= <string>
114 <slot_offset> ::= <byte> (offset of slot above struct)
115 (`object')
116
117 <string> ::= <size>{<char>} (<size> times <char>)
118 <char> ::= <byte>
119
120 <byte> ::= (8 bits)
121 <word> ::= (32 bits)
122 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
123
124 static HashTable saveTable;
125 static HashTable saveClassTable;
126 static HashTable saveNilRefTable;
127 static Chain candidateSaveRelations;
128
129 static inline Int
setSavedObj(Any obj)130 setSavedObj(Any obj)
131 { objects_saved++;
132
133 appendHashTable(saveTable, obj, toInt(objects_saved));
134
135 return toInt(objects_saved);
136 }
137
138 static inline Int
setSavedClass(Class class)139 setSavedClass(Class class)
140 { classes_saved++;
141
142 appendHashTable(saveClassTable, class, toInt(classes_saved));
143
144 return toInt(classes_saved);
145 }
146
147 Int
isSavedObject(Any obj)148 isSavedObject(Any obj)
149 { return getMemberHashTable(saveTable, obj);
150 }
151
152 #define isSavedClass(class) getMemberHashTable(saveClassTable, class)
153
154 static status
candidateSaveRelation(Any r)155 candidateSaveRelation(Any r)
156 { if ( !isSavedObject(r) )
157 { if ( !candidateSaveRelations )
158 candidateSaveRelations = newObject(ClassChain, r, EAV);
159 else
160 appendChain(candidateSaveRelations, r);
161 }
162
163 succeed;
164 }
165
166
167 static status
saveRelations(FileObj f)168 saveRelations(FileObj f)
169 { Any r;
170
171 while( candidateSaveRelations &&
172 (r = getDeleteHeadChain(candidateSaveRelations)) )
173 { if ( !isSavedObject(r) )
174 TRY(send(r, NAME_SaveRelation, f, EAV));
175 }
176
177 succeed;
178 }
179
180
181 static status
saveNilRefs(FileObj f)182 saveNilRefs(FileObj f)
183 { if ( saveNilRefTable )
184 { for_hash_table(saveNilRefTable, s,
185 { Instance inst = s->name;
186 Variable var = s->value;
187 Any to = inst->slots[valInt(var->offset)];
188 Int ref;
189
190 if ( onDFlag(var, D_CLONE_REFCHAIN) )
191 { Cell cell;
192 Chain ch = to;
193
194 storeCharFile(f, 'r');
195 storeIntFile(f, storeClass(classOfObject(inst), f));
196 storeIdObject(inst, isSavedObject(inst), f);
197 storeIntFile(f, var->offset);
198 for_cell(cell, ch)
199 { if ( (ref=isSavedObject(cell->value)) )
200 { storeCharFile(f, 'R');
201 storeIdObject(cell->value, ref, f);
202 }
203 }
204 storeCharFile(f, 'x');
205 } else
206 { if ( (ref = isSavedObject(to)) )
207 { DEBUG(NAME_save,
208 Cprintf("storing nil-ref %s-%s->%s\n",
209 pp(inst), pp(var->name), pp(to)));
210 storeCharFile(f, 'n');
211 storeIntFile(f, storeClass(classOfObject(inst), f));
212 storeIdObject(inst, isSavedObject(inst), f);
213 storeIntFile(f, var->offset);
214 storeIdObject(to, ref, f);
215 }
216 }
217 });
218
219 freeHashTable(saveNilRefTable);
220 saveNilRefTable = NULL;
221 }
222
223 succeed;
224 }
225
226
227 status
saveInFileObject(Any obj,FileObj file)228 saveInFileObject(Any obj, FileObj file)
229 { status result;
230 string magic;
231
232 TRY(send(file, NAME_kind, NAME_binary, EAV) &&
233 send(file, NAME_open, NAME_write, EAV));
234
235 if ( SaveMagic == NULL )
236 SaveMagic = SAVEMAGIC;
237
238 objects_saved = classes_saved = save_nesting = 0;
239 str_set_n_ascii(&magic, strlen(SaveMagic), SaveMagic);
240 storeStringFile(file, &magic);
241 storeWordFile(file, (Any) SAVEVERSION);
242 saveTable = createHashTable(toInt(256), NAME_none);
243 saveClassTable = createHashTable(toInt(256), NAME_none);
244 if ( candidateSaveRelations )
245 clearChain(candidateSaveRelations);
246 result = (storeObject(obj, file) &&
247 saveRelations(file) &&
248 saveNilRefs(file) &&
249 storeCharFile(file, 'x'));
250 closeFile(file);
251 if ( !result )
252 removeFile(file);
253 DEBUG(NAME_statistics, Cprintf("Saved %d objects of %d classes\n",
254 objects_saved, classes_saved));
255 freeHashTable(saveTable);
256 freeHashTable(saveClassTable);
257
258
259 return result ? SUCCEED : FAIL;
260 }
261
262
263 status
storeObject(Any obj,FileObj file)264 storeObject(Any obj, FileObj file)
265 { /*DEBUG(NAME_save, Cprintf("Storing %s from %ld\n",
266 pp(obj), ftell(file->fd)));*/
267
268 if ( isInteger(obj) )
269 { storeCharFile(file, 'I');
270 storeIntFile(file, obj);
271 succeed;
272 }
273
274 assert(isObject(obj));
275
276 if ( instanceOfObject(obj, ClassVar) )
277 { intptr_t a = (char*)obj - (char*)Arg(1);
278
279 a++; /* count 1.. */
280 if ( a >= 1 && a <= 9 )
281 return storeCharFile(file, '0' + (int) a);
282 else if ( a == 10 )
283 return storeCharFile(file, '0');
284 else if ( obj == RECEIVER )
285 return storeCharFile(file, 'r');
286 } else if ( instanceOfObject(obj, ClassConstant) )
287 { if ( isNil(obj) )
288 return storeCharFile(file, 'n');
289 else if ( isDefault(obj) )
290 return storeCharFile(file, 'd');
291 else if ( isOn(obj) ) /* booleans are constants! */
292 return storeCharFile(file, 'a');
293 else if ( isOff(obj) )
294 return storeCharFile(file, 'u');
295 }
296
297 { Class class = classOfObject(obj);
298 Name name;
299
300 if ( isAClass(class, ClassName) )
301 { if ( class == ClassName )
302 { storeCharFile(file, 'N');
303 storeNameFile(file, obj);
304 succeed;
305 } else if ( class->name == NAME_lispSymbol ) /* HACK */
306 { storeCharFile(file, 'S');
307 storeNameFile(file, obj);
308 storeNameFile(file, get(obj, NAME_package, EAV));
309 succeed;
310 }
311 }
312
313 DEBUG(NAME_save, Cprintf(" [%3d] Storing %s from %ld\n",
314 save_nesting, pp(obj), Stell(file->fd)));
315
316 if ( class->saveStyle == NAME_nil )
317 { return storeCharFile(file, 'n');
318 } else if ( class->saveStyle == NAME_external &&
319 (name = getNameAssoc(obj)) )
320 { storeCharFile(file, 'A');
321 storeNameFile(file, name);
322 succeed;
323 } else /*if ( equalName(class->saveStyle, NAME_normal) )*/
324 { Int ref, classref;
325 status rval;
326 Any sref;
327
328 if ( (ref = isSavedObject(obj)) )
329 { DEBUG(NAME_save, Cprintf("Storing reference\n"));
330 storeCharFile(file, 'R');
331 return storeIdObject(obj, ref, file);
332 }
333
334 if ( (sref = qadGetv(obj, NAME_storageReference, 0, NULL)) )
335 { storeCharFile(file, 'D');
336 storeNameFile(file, class->name);
337 return storeObject(sref, file);
338 }
339
340 ref = setSavedObj(obj);
341
342 TRY( classref = storeClass(class, file) );
343 storeCharFile(file, 'O');
344 storeIntFile(file, classref);
345 storeIdObject(obj, ref, file);
346 storeExtensionsObject(obj, file);
347 save_nesting++;
348 if ( class->saveFunction )
349 { DEBUG(NAME_save, Cprintf("Using private function\n"));
350 rval = (*class->saveFunction)(obj, file);
351 } else
352 { if ( allPceSlotsClass(class) )
353 rval = storeSlotsObject(obj, file);
354 else
355 { errorPce(obj, NAME_cannotSaveObject, NAME_alienData);
356 rval = storeObject(NIL, file);
357 }
358 }
359 save_nesting--;
360
361 return rval;
362 }
363 }
364 }
365
366
367 static status
storeExtensionsObject(Any obj,FileObj file)368 storeExtensionsObject(Any obj, FileObj file)
369 { if ( onFlag(obj, F_CONSTRAINT|F_ATTRIBUTE|F_SENDMETHOD|F_GETMETHOD|
370 F_HYPER|F_RECOGNISER) )
371 { if ( onFlag(obj, F_CONSTRAINT) )
372 { storeCharFile(file, 'c');
373 storeObject(getAllConstraintsObject(obj, ON), file);
374 }
375 if ( onFlag(obj, F_ATTRIBUTE) )
376 { storeCharFile(file, 'a');
377 storeObject(getAllAttributesObject(obj, ON), file);
378 }
379 if ( onFlag(obj, F_SENDMETHOD) )
380 { storeCharFile(file, 's');
381 storeObject(getAllSendMethodsObject(obj, ON), file);
382 }
383 if ( onFlag(obj, F_GETMETHOD) )
384 { storeCharFile(file, 'g');
385 storeObject(getAllGetMethodsObject(obj, ON), file);
386 }
387 if ( onFlag(obj, F_HYPER) )
388 { Chain hypers = getAllHypersObject(obj, ON);
389 Cell cell;
390
391 for_cell(cell, hypers)
392 candidateSaveRelation(cell->value);
393 }
394 if ( onFlag(obj, F_RECOGNISER) )
395 { storeCharFile(file, 'r');
396 storeObject(getAllRecognisersGraphical(obj, ON), file);
397 }
398 }
399
400 return storeCharFile(file, 'x');
401 }
402
403
404 static status
storeSlotObject(Instance inst,Variable var,FileObj file)405 storeSlotObject(Instance inst, Variable var, FileObj file)
406 { int i = valInt(var->offset);
407 Any val = inst->slots[i];
408
409 if ( onDFlag(var, D_SAVE_NORMAL) )
410 return storeObject(val, file);
411
412 if ( onDFlag(var, D_SAVE_NIL|D_CLONE_REFCHAIN) )
413 { if ( isSavedObject(val) )
414 return storeObject(val, file);
415 if ( !saveNilRefTable )
416 saveNilRefTable = createHashTable(toInt(32), NAME_none);
417 appendHashTable(saveNilRefTable, inst, var);
418 storeObject(NIL, file);
419 }
420
421 succeed;
422 }
423
424
425 status
storeSlotsObject(Any obj,FileObj file)426 storeSlotsObject(Any obj, FileObj file)
427 { Class class = classOfObject(obj);
428
429 for_vector(class->instance_variables, Variable var,
430 storeSlotObject(obj, var, file));
431
432 succeed;
433 }
434
435
436 static status
storeIdObject(Any obj,Int id,FileObj file)437 storeIdObject(Any obj, Int id, FileObj file)
438 { Name name;
439
440 if ( (name = getNameAssoc(obj)) )
441 { storeCharFile(file, 'N');
442 storeNameFile(file, name);
443 succeed;
444 }
445 storeCharFile(file, 'I');
446 storeIntFile(file, id);
447 succeed;
448 }
449
450
451
452 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
453 StoreClass stores the instance layout, as far as PCE typed slots are
454 concerned. Alien slots are taken care of by specialised load/store
455 functions defined on the class itself.
456 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
457
458 static Int
storeClass(Class class,FileObj file)459 storeClass(Class class, FileObj file)
460 { Int ref;
461
462 if ( (ref = isSavedClass(class)) )
463 return ref;
464
465 ref = setSavedClass(class);
466 storeCharFile(file, 'C');
467 storeNameFile(file, class->name);
468 storeIntFile(file, ref);
469 storeIntFile(file, toInt(pceSlotsClass(class)));
470 storeSlotsClass(class, file);
471
472 return ref;
473 }
474
475
476 static int
pceSlotsClass(Class class)477 pceSlotsClass(Class class)
478 { int pce_slots = 0;
479 int slots = valInt(class->slots);
480 int n;
481
482 for(n = 0; n<slots; n++)
483 if ( isPceSlot(class, n) )
484 pce_slots++;
485
486 return pce_slots;
487 }
488
489
490 static status
storeSlotsClass(Class class,FileObj file)491 storeSlotsClass(Class class, FileObj file)
492 { for_vector(class->instance_variables, Variable var,
493 if ( var->type->kind != NAME_alien )
494 storeNameFile(file, var->name));
495
496 succeed;
497 }
498
499
500 /********************************
501 * LOADING *
502 *********************************/
503
504 struct classdef
505 { Class class; /* current class structure */
506 Name class_name; /* name of this class */
507 int slots; /* number of saved slots */
508 int *offset; /* array of slot offsets */
509 Name *name; /* array of slot-names */
510 };
511
512 static HashTable savedClassTable; /* table with saved classes */
513 static HashTable restoreTable; /* restored objects table */
514 static Chain restoreMessages; /* messages for restoration */
515
516 int
loadWord(IOSTREAM * fd)517 loadWord(IOSTREAM *fd)
518 {
519 #ifndef WORDS_BIGENDIAN
520 union
521 { unsigned int l;
522 unsigned char c[4];
523 } cvrt;
524 int rval;
525
526 cvrt.l = Sgetw(fd);
527 rval = (cvrt.c[0] << 24) |
528 (cvrt.c[1] << 16) |
529 (cvrt.c[2] << 8) |
530 cvrt.c[3];
531 DEBUG(NAME_byteOrder, Cprintf("loadWord(0x%lx) --> %ld\n", cvrt.l, rval));
532 return rval;
533 #else /*WORDS_BIGENDIAN*/
534 return Sgetw(fd);
535 #endif /*WORDS_BIGENDIAN*/
536 }
537
538
539 #ifdef WORDS_BIGENDIAN
540 static const int double_byte_order[] = { 7,6,5,4,3,2,1,0 };
541 #else
542 static const int double_byte_order[] = { 0,1,2,3,4,5,6,7 };
543 #endif
544
545 #define BYTES_PER_DOUBLE (sizeof(double_byte_order)/sizeof(int))
546
547 double
loadDouble(IOSTREAM * fd)548 loadDouble(IOSTREAM *fd)
549 { double f;
550 unsigned char *cl = (unsigned char *)&f;
551 unsigned int i;
552
553 for(i=0; i<BYTES_PER_DOUBLE; i++)
554 { int c = Sgetc(fd);
555
556 cl[double_byte_order[i]] = c;
557 }
558
559 return f;
560 }
561
562
563 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
564 loadStringFile() loads a string saved using storeStringFile(). See there for
565 format details.
566 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
567
568 int
loadStringFile(IOSTREAM * fd,PceString s)569 loadStringFile(IOSTREAM *fd, PceString s)
570 { int size = loadWord(fd);
571
572 if ( size >= 0 )
573 { str_inithdr(s, FALSE);
574 s->s_size = size;
575
576 str_alloc(s);
577 if ( Sfread(s->s_textA, sizeof(char), size, fd) != (size_t)size )
578 fail;
579 } else
580 { int i;
581 charW *d;
582 IOENC oenc;
583
584 str_inithdr(s, TRUE);
585 s->s_size = -size;
586 str_alloc(s);
587
588 oenc = fd->encoding;
589 fd->encoding = ENC_UTF8;
590 for(d=s->s_textW, i=0; i<s->s_size; i++)
591 { int chr = Sgetcode(fd);
592
593 if ( chr != EOF )
594 { *d++ = chr;
595 } else
596 { fd->encoding = oenc;
597 fail;
598 }
599 }
600 }
601
602 succeed;
603 }
604
605
606 static Name
loadName(IOSTREAM * fd)607 loadName(IOSTREAM *fd)
608 { string s;
609
610 if ( loadStringFile(fd, &s) )
611 { Name name = StringToName(&s);
612 str_unalloc(&s);
613
614 return name;
615 }
616
617 return NULL;
618 }
619
620
621 void
restoreMessage(Any msg)622 restoreMessage(Any msg)
623 { if ( !restoreMessages )
624 restoreMessages = newObject(ClassChain, EAV);
625
626 appendChain(restoreMessages, msg);
627 }
628
629
630 static status
loadNilRef(IOSTREAM * fd)631 loadNilRef(IOSTREAM * fd)
632 { Int classid = toInt(loadWord(fd));
633 Any r1 = loadNameObject(fd);
634 int offset = loadWord(fd);
635 Any r2 = loadNameObject(fd);
636 ClassDef def = getMemberHashTable(savedClassTable, classid);
637 Instance f = getMemberHashTable(restoreTable, r1);
638 Any t = getMemberHashTable(restoreTable, r2);
639
640 if ( !def )
641 return errorPce(LoadFile, NAME_noSavedClassDef, classid);
642 if ( !f )
643 return errorPce(LoadFile, NAME_referencedObjectNotLoaded, r1);
644 if ( !t )
645 return errorPce(LoadFile, NAME_referencedObjectNotLoaded, r2);
646
647 if ( def->offset[offset] >= 0 )
648 { DEBUG(NAME_save, Cprintf("Restoring (nil)ref %s-%s --> %s\n",
649 pp(f), pp(def->name[offset]), pp(t)));
650 assignField(f, &(f->slots[def->offset[offset]]), t);
651 }
652 /* else slot is gone; no problem I think */
653
654 succeed;
655 }
656
657
658 static status
loadReferenceChain(IOSTREAM * fd)659 loadReferenceChain(IOSTREAM *fd)
660 { Int classid = toInt(loadWord(fd));
661 Any r1 = loadNameObject(fd);
662 int offset = loadWord(fd);
663 ClassDef def = getMemberHashTable(savedClassTable, classid);
664 Instance f = getMemberHashTable(restoreTable, r1);
665
666 if ( !def )
667 return errorPce(LoadFile, NAME_noSavedClassDef, classid);
668 if ( !f )
669 return errorPce(LoadFile, NAME_referencedObjectNotLoaded, r1);
670
671 if ( def->offset[offset] >= 0 )
672 { Chain ch = newObject(ClassChain, EAV);
673 int c;
674
675 assignField(f, &(f->slots[def->offset[offset]]), ch);
676 do
677 { switch((c=Sgetc(fd)))
678 { case 'R':
679 { Any r2 = loadNameObject(fd);
680 Any o2 = getMemberHashTable(restoreTable, r2);
681
682 if ( !o2 )
683 return errorPce(LoadFile, NAME_referencedObjectNotLoaded, r2);
684 appendChain(ch, o2);
685 break;
686 }
687 case 'x':
688 break;
689 default:
690 errorPce(f, NAME_illegalCharacter, toInt(c), toInt(Stell(fd)));
691 fail;
692 }
693 } while( c != 'x' );
694 }
695 /* else slot is gone; no problem I think */
696
697 succeed;
698 }
699
700
701 status
checkObjectMagic(IOSTREAM * fd)702 checkObjectMagic(IOSTREAM *fd)
703 { status rval;
704 long l;
705 long ls;
706
707 if ( SaveMagic == NULL )
708 SaveMagic = SAVEMAGIC;
709
710 ls = (long)strlen(SaveMagic);
711
712 if ( (l=loadWord(fd)) == ls )
713 { char tmp[LINESIZE];
714
715 Sfread(tmp, sizeof(char), sizeof(SAVEMAGIC)-1, fd);
716 tmp[ls] = EOS;
717 DEBUG(NAME_save, Cprintf("magic = ``%s''; SaveMagic = ``%s''\n",
718 tmp, SaveMagic) );
719 if ( strncmp(tmp, SaveMagic, ls - 1) == 0 )
720 rval = SUCCEED;
721 else
722 rval = FAIL;
723 } else
724 { rval = FAIL;
725 DEBUG(NAME_save, Cprintf("First word = %ld, should be %d\n", l, ls) );
726 }
727
728 return rval;
729 }
730
731
732 Any
getObjectSourceSink(SourceSink f)733 getObjectSourceSink(SourceSink f)
734 { IOSTREAM *fd;
735 Any result;
736
737 if ( !(fd = Sopen_object(f, "rbr")) )
738 fail;
739
740 LoadFile = f; /* TBD: pass as argument */
741
742 if ( !checkObjectMagic(fd) )
743 { Sclose(fd);
744
745 errorPce(f, NAME_badFile, NAME_object);
746 fail;
747 }
748
749 restoreVersion = loadWord(fd);
750 if ( restoreVersion != SAVEVERSION )
751 errorPce(f, NAME_newSaveVersion,
752 toInt(restoreVersion), toInt(SAVEVERSION));
753
754 savedClassTable = createHashTable(toInt(128), NAME_none);
755 restoreTable = createHashTable(toInt(256), NAME_none);
756 if ( restoreMessages )
757 clearChain(restoreMessages);
758 if ( (result = loadObject(fd)) )
759 addCodeReference(result);
760 if ( restoreVersion >= 13 )
761 { char c;
762
763 do
764 { switch((c=Sgetc(fd)))
765 { case 's': /* support (relation) objects */
766 if ( !loadObject(fd) )
767 fail; /* TBD */
768 break;
769 case 'n':
770 if ( !loadNilRef(fd) )
771 fail;
772 break;
773 case 'r':
774 if ( !loadReferenceChain(fd) )
775 fail;
776 break;
777 case 'x':
778 break;
779 default:
780 errorPce(f, NAME_illegalCharacter, toInt(c), toInt(Stell(fd)));
781 fail;
782 }
783 } while( c != 'x' );
784 }
785
786 freeHashTable(restoreTable);
787 freeHashTable(savedClassTable);
788 Sclose(fd);
789
790 if ( result )
791 { if ( restoreMessages )
792 { Any msg;
793
794 while((msg= getDeleteHeadChain(restoreMessages)))
795 forwardCodev(msg, 0, NULL);
796 }
797
798 delCodeReference(result);
799 pushAnswerObject(result);
800 }
801
802 LoadFile = NULL;
803
804 answer(result);
805 }
806
807
808 static void
updateFlagsObject(Any obj)809 updateFlagsObject(Any obj)
810 { if ( instanceOfObject(obj, ClassFunction) )
811 setFlag(obj, F_ACTIVE|F_NOTANY);
812 }
813
814
815 static status
loadExtensionsObject(Instance obj,IOSTREAM * fd)816 loadExtensionsObject(Instance obj, IOSTREAM *fd)
817 { if ( restoreVersion <= 7 )
818 succeed; /* extensions in interceptor */
819
820 for(;;)
821 { char c;
822 Any ext;
823
824 if ( restoreVersion == 8 )
825 { if ( (c=Sgetc(fd)) != 'e' )
826 { Sungetc(c, fd);
827 succeed;
828 }
829 }
830
831 switch(c=Sgetc(fd))
832 { case 'x':
833 succeed;
834 case 'a':
835 setFlag(obj, F_ATTRIBUTE);
836 appendHashTable(ObjectAttributeTable, obj, ext = loadObject(fd));
837 addRefObj(ext);
838 break;
839 case 'c':
840 setFlag(obj, F_CONSTRAINT);
841 appendHashTable(ObjectConstraintTable, obj, ext = loadObject(fd));
842 addRefObj(ext);
843 break;
844 case 's':
845 setFlag(obj, F_SENDMETHOD);
846 appendHashTable(ObjectSendMethodTable, obj, ext = loadObject(fd));
847 addRefObj(ext);
848 break;
849 case 'g':
850 setFlag(obj, F_GETMETHOD);
851 appendHashTable(ObjectGetMethodTable, obj, ext = loadObject(fd));
852 addRefObj(ext);
853 break;
854 case 'r':
855 setFlag(obj, F_RECOGNISER);
856 appendHashTable(ObjectRecogniserTable, obj, ext = loadObject(fd));
857 addRefObj(ext);
858 break;
859 case 'h':
860 setFlag(obj, F_HYPER);
861 appendHashTable(ObjectHyperTable, obj, ext = loadObject(fd));
862 addRefObj(ext);
863 break;
864 default:
865 errorPce(LoadFile, NAME_illegalCharacter, toInt(c), toInt(Stell(fd)));
866 fail;
867 }
868 }
869 }
870
871
872 Any
loadObject(IOSTREAM * fd)873 loadObject(IOSTREAM *fd)
874 { int c;
875 #ifndef O_RUNTIME
876 long start = 0;
877 #endif
878
879 DEBUG(NAME_save, start = Stell(fd));
880
881 switch( c = Sgetc(fd) )
882 { case 'd': return DEFAULT;
883 case 'n': return NIL;
884 case 'a': return ON;
885 case 'u': return OFF;
886 case 'r': return RECEIVER;
887 case '1': return Arg(1);
888 case '2': return Arg(2);
889 case '3': return Arg(3);
890 case '4': return Arg(4);
891 case '5': return Arg(5);
892 case '6': return Arg(6);
893 case '7': return Arg(7);
894 case '8': return Arg(8);
895 case '9': return Arg(9);
896 case '0': return Arg(10);
897 case 'N': return loadName(fd);
898 case 'I': return toInt(loadWord(fd));
899 case 'R': { Any r;
900 Any ref = loadNameObject(fd);
901
902 if ( !(r = getMemberHashTable(restoreTable, ref)) )
903 { errorPce(LoadFile, NAME_referencedObjectNotLoaded, ref);
904 fail;;
905 }
906 return r;
907 }
908 case 'A': { Any r;
909 Name name = loadName(fd);
910
911 if ( !(r = getObjectFromReferencePce(PCE, name)) )
912 { errorPce(NIL, NAME_noAssoc, name);
913 fail;
914 }
915 return r;
916 }
917 case 'D': { Name classname = loadName(fd);
918 Type t = nameToType(classname);
919 Any sref = loadObject(fd);
920 Any rval;
921
922 if ( !isClassType(t) )
923 { errorPce(t, NAME_notClassType);
924 return NIL;
925 }
926
927 if ( (rval = checkType(sref, t, NIL)) )
928 return rval;
929
930 errorPce(classname, NAME_cannotConvert, sref);
931 return NIL;
932 }
933 case 'C': restoreClass(fd);
934 if ( (c=Sgetc(fd)) != 'O' )
935 { errorPce(LoadFile, NAME_illegalCharacter,
936 toInt(c), toInt(Stell(fd)));
937 fail;
938 }
939 /* FALLTHROUGH */
940 case 'O': { ClassDef def;
941 Int classid = toInt(loadWord(fd));
942 Any name;
943
944 if ( !(def = getMemberHashTable(savedClassTable, classid)) )
945 { errorPce(LoadFile, NAME_noSavedClassDef, classid);
946 fail;
947 }
948
949 name = loadNameObject(fd);
950 if ( def->class )
951 { Instance obj = allocObject(def->class, FALSE);
952
953 if ( isName(name) )
954 newAssoc(name, obj);
955 addCodeReference(obj);
956
957 DEBUG(NAME_save, Cprintf("Loading %s from %ld\n",
958 pp(obj), start));
959
960 appendHashTable(restoreTable, name, obj);
961 loadExtensionsObject(obj, fd);
962
963 if ( def->class->loadFunction != NULL )
964 (*def->class->loadFunction)(obj, fd, def);
965 else
966 loadSlotsObject(obj, fd, def);
967 updateFlagsObject(obj);
968
969 if ( SAVEVERSION != restoreVersion || PCEdebugging )
970 TRY(checkConvertedObject(obj, def));
971
972 createdClass(def->class, obj, NAME_loaded);
973
974 DEBUG(NAME_save, CheckObject(obj, OFF));
975 delCodeReference(obj);
976
977 return obj;
978 } else /* no class; load into sheet */
979 { int i;
980 Any slotValue;
981 Sheet sh = createObjectv(isName(name) ? name : (Name) NIL,
982 ClassSheet, 0, NULL);
983
984 valueSheet(sh, NAME_className, def->class_name);
985 DEBUG(NAME_save, Cprintf("Loading %s from %ld\n",
986 pp(sh), start));
987 appendHashTable(restoreTable, name, sh);
988 loadExtensionsObject((Any) sh, fd);
989
990 for( i=0; i<def->slots; i++ )
991 { if ( (slotValue = loadObject(fd)) == FAIL )
992 fail;
993 valueSheet(sh, def->name[i], slotValue);
994 }
995
996 DEBUG(NAME_save, CheckObject(sh, OFF));
997 return sh;
998 }
999 }
1000 case 'S': /* lisp-symbol hack */
1001 { string ns, ps;
1002
1003 if ( loadStringFile(fd, &ns) &&
1004 loadStringFile(fd, &ps) )
1005 { Name name = StringToName(&ns);
1006 Name package = StringToName(&ps);
1007 Class symbol_class = getConvertClass(ClassClass, NAME_lispSymbol);
1008 Any symbol = newObject(symbol_class, name, package, EAV);
1009
1010 str_unalloc(&ns);
1011 str_unalloc(&ps);
1012
1013 return symbol;
1014 }
1015
1016 fail;
1017 }
1018
1019 default: { long index;
1020
1021 index = Stell(fd) - 1;
1022 errorPce(LoadFile, NAME_illegalCharacter,
1023 toInt(c), toInt(index));
1024 fail;
1025 }
1026 }
1027 }
1028
1029
1030 static Any
loadNameObject(IOSTREAM * fd)1031 loadNameObject(IOSTREAM *fd)
1032 { int c;
1033
1034 switch( (c = Sgetc(fd)) )
1035 { case 'I': return (Any) toInt(loadWord(fd));
1036 case 'N': return (Any) loadName(fd);
1037 default: errorPce(LoadFile, NAME_illegalCharacter,
1038 toInt(c), toInt(Stell(fd)-1));
1039 fail;
1040 }
1041 }
1042
1043
1044 static status
restoreClass(IOSTREAM * fd)1045 restoreClass(IOSTREAM *fd)
1046 { Name name = loadName(fd);
1047 Int classid = toInt(loadWord(fd));
1048 int slots = loadWord(fd);
1049 int i;
1050 ClassDef def;
1051
1052 if ( restoreVersion == 1 )
1053 slots++;
1054
1055 def = alloc(sizeof(struct classdef));
1056 def->class_name = name;
1057 def->offset = alloc(slots * sizeof(int));
1058 def->name = alloc(slots * sizeof(Name));
1059
1060 if ( (def->class = checkType(name, TypeClass, NIL)) )
1061 realiseClass(def->class);
1062 else
1063 errorPce(LoadFile, NAME_loadNoClass, name);
1064 def->slots = slots;
1065 appendHashTable(savedClassTable, classid, def);
1066
1067 for( i = 0; i<slots; i++ )
1068 { Name name = loadName(fd);
1069
1070 def->name[i] = name;
1071 if ( def->class )
1072 { def->offset[i] = offsetVariable(def->class, name);
1073 if ( def->offset[i] < 0 )
1074 { errorPce(LoadFile, NAME_loadOldSlot, def->class, name);
1075 }
1076 }
1077 }
1078
1079 succeed;
1080 }
1081
1082
1083 static status
definedSlotClassDef(ClassDef def,Name slot)1084 definedSlotClassDef(ClassDef def, Name slot)
1085 { int i;
1086
1087 for(i=0; i<def->slots; i++)
1088 if ( def->name[i] == slot )
1089 succeed;
1090
1091 fail;
1092 }
1093
1094
1095 static int
offsetVariable(Class class,Name name)1096 offsetVariable(Class class, Name name)
1097 { Variable var;
1098
1099 if ( (var = getInstanceVariableClass(class, name)) &&
1100 var->type->kind != NAME_alien )
1101 return valInt(var->offset);
1102
1103 return -1;
1104 }
1105
1106
1107 status
loadSlotsObject(Any obj,IOSTREAM * fd,ClassDef def)1108 loadSlotsObject(Any obj, IOSTREAM *fd, ClassDef def)
1109 { int i;
1110 Any slotValue;
1111 Instance inst = obj;
1112
1113 for( i=0; i<def->slots; i++ )
1114 { int slot;
1115
1116 if ( (slotValue = loadObject(fd)) == FAIL )
1117 fail;
1118 if ( (slot = def->offset[i]) < 0 ) /* slot out of use */
1119 { if ( hasSendMethodObject(inst, NAME_convertOldSlot) ) send(inst,
1120 NAME_convertOldSlot, def->name[i], slotValue, EAV); continue; } if (
1121 restoreVersion != SAVEVERSION || PCEdebugging ) { Any converted;
1122 Variable var = def->class->instance_variables->elements[slot];
1123
1124 if ( (converted = checkType(slotValue, var->type, inst)) )
1125 slotValue = converted;
1126 }
1127 assignField(inst, &(inst->slots[slot]), slotValue);
1128 }
1129
1130 succeed;
1131 }
1132
1133
1134 static status
checkConvertedObject(Any obj,ClassDef def)1135 checkConvertedObject(Any obj, ClassDef def)
1136 { Class class = def->class;
1137 int slots = valInt(class->slots);
1138 Instance inst = obj;
1139 int i;
1140
1141 if ( hasSendMethodObject(inst, NAME_convertLoadedObject) )
1142 send(inst, NAME_convertLoadedObject,
1143 toInt(restoreVersion),
1144 toInt(SAVEVERSION), EAV);
1145
1146 for(i=0; i<slots; i++)
1147 { if ( isPceSlot(class, i) )
1148 { Variable var = getInstanceVariableClass(class, toInt(i));
1149 Any value = inst->slots[i];
1150
1151 if ( !var )
1152 { Cprintf("Can't find variable %d of %s\n", i, pp(class));
1153 continue;
1154 }
1155
1156 if ( isDefault(value) && getClassVariableClass(class, var->name) )
1157 continue;
1158
1159 if ( hasSendMethodObject(inst, NAME_initialiseNewSlot) &&
1160 !definedSlotClassDef(def, var->name) )
1161 send(inst, NAME_initialiseNewSlot, var, EAV);
1162 value = inst->slots[i];
1163
1164 if ( !checkType(value, var->type, inst) &&
1165 !(isNil(value) && onDFlag(var, D_SAVE_NIL)) )
1166 errorPce(inst, NAME_badSlotValue, var->name, value);
1167 }
1168 }
1169
1170 succeed;
1171 }
1172