diff options
author | Torne Wuff <torne@wolfpuppy.org.uk> | 2010-01-17 22:15:13 +0000 |
---|---|---|
committer | Torne Wuff <torne@wolfpuppy.org.uk> | 2010-01-17 22:15:13 +0000 |
commit | 7f28c94eda576e3f972fc05468188986f2e45885 (patch) | |
tree | e03b94613028d16855a5d3df0f4853e077931214 /apps/plugins/frotz/quetzal.c | |
parent | 563f2602f471208cb8544a36539a79dcceaad643 (diff) | |
download | rockbox-7f28c94eda576e3f972fc05468188986f2e45885.tar.gz rockbox-7f28c94eda576e3f972fc05468188986f2e45885.zip |
New plugin: frotz, a Z-machine interpreter, for playing interactive fiction.
The interpreter more or less passes all the tests in the z-machine test suite.
It should build for every target except Archos (for which it is disabled).
git-svn-id: svn://svn.rockbox.org/rockbox/trunk@24267 a1c6a512-1295-4272-9138-f99709370657
Diffstat (limited to 'apps/plugins/frotz/quetzal.c')
-rw-r--r-- | apps/plugins/frotz/quetzal.c | 541 |
1 files changed, 541 insertions, 0 deletions
diff --git a/apps/plugins/frotz/quetzal.c b/apps/plugins/frotz/quetzal.c new file mode 100644 index 0000000000..a75ade856e --- /dev/null +++ b/apps/plugins/frotz/quetzal.c | |||
@@ -0,0 +1,541 @@ | |||
1 | /* quetzal.c - Saving and restoring of Quetzal files. | ||
2 | * Written by Martin Frost <mdf@doc.ic.ac.uk> | ||
3 | * | ||
4 | * Changes for Rockbox copyright 2009 Torne Wuff | ||
5 | * | ||
6 | * This file is part of Frotz. | ||
7 | * | ||
8 | * Frotz is free software; you can redistribute it and/or modify | ||
9 | * it under the terms of the GNU General Public License as published by | ||
10 | * the Free Software Foundation; either version 2 of the License, or | ||
11 | * (at your option) any later version. | ||
12 | * | ||
13 | * Frotz is distributed in the hope that it will be useful, | ||
14 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
15 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
16 | * GNU General Public License for more details. | ||
17 | * | ||
18 | * You should have received a copy of the GNU General Public License | ||
19 | * along with this program; if not, write to the Free Software | ||
20 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA | ||
21 | */ | ||
22 | |||
23 | #include "frotz.h" | ||
24 | |||
25 | #define far | ||
26 | |||
27 | #define get_c fgetc | ||
28 | #define put_c fputc | ||
29 | |||
30 | typedef unsigned long zlong; | ||
31 | |||
32 | /* | ||
33 | * This is used only by save_quetzal. It probably should be allocated | ||
34 | * dynamically rather than statically. | ||
35 | */ | ||
36 | |||
37 | static zword frames[STACK_SIZE/4+1]; | ||
38 | |||
39 | /* | ||
40 | * ID types. | ||
41 | */ | ||
42 | |||
43 | #define makeid(a,b,c,d) ((zlong) (((a)<<24) | ((b)<<16) | ((c)<<8) | (d))) | ||
44 | |||
45 | #define ID_FORM makeid ('F','O','R','M') | ||
46 | #define ID_IFZS makeid ('I','F','Z','S') | ||
47 | #define ID_IFhd makeid ('I','F','h','d') | ||
48 | #define ID_UMem makeid ('U','M','e','m') | ||
49 | #define ID_CMem makeid ('C','M','e','m') | ||
50 | #define ID_Stks makeid ('S','t','k','s') | ||
51 | #define ID_ANNO makeid ('A','N','N','O') | ||
52 | |||
53 | /* | ||
54 | * Various parsing states within restoration. | ||
55 | */ | ||
56 | |||
57 | #define GOT_HEADER 0x01 | ||
58 | #define GOT_STACK 0x02 | ||
59 | #define GOT_MEMORY 0x04 | ||
60 | #define GOT_NONE 0x00 | ||
61 | #define GOT_ALL 0x07 | ||
62 | #define GOT_ERROR 0x80 | ||
63 | |||
64 | /* | ||
65 | * Macros used to write the files. | ||
66 | */ | ||
67 | |||
68 | #define write_byte(fp,b) (put_c (b, fp) != EOF) | ||
69 | #define write_bytx(fp,b) write_byte (fp, (b) & 0xFF) | ||
70 | #define write_word(fp,w) \ | ||
71 | (write_bytx (fp, (w) >> 8) && write_bytx (fp, (w))) | ||
72 | #define write_long(fp,l) \ | ||
73 | (write_bytx (fp, (l) >> 24) && write_bytx (fp, (l) >> 16) && \ | ||
74 | write_bytx (fp, (l) >> 8) && write_bytx (fp, (l))) | ||
75 | #define write_chnk(fp,id,len) \ | ||
76 | (write_long (fp, (id)) && write_long (fp, (len))) | ||
77 | #define write_run(fp,run) \ | ||
78 | (write_byte (fp, 0) && write_byte (fp, (run))) | ||
79 | |||
80 | /* Read one word from file; return TRUE if OK. */ | ||
81 | static bool read_word (int f, zword *result) | ||
82 | { | ||
83 | int a, b; | ||
84 | |||
85 | if ((a = get_c (f)) == EOF) return FALSE; | ||
86 | if ((b = get_c (f)) == EOF) return FALSE; | ||
87 | |||
88 | *result = ((zword) a << 8) | (zword) b; | ||
89 | return TRUE; | ||
90 | } | ||
91 | |||
92 | /* Read one long from file; return TRUE if OK. */ | ||
93 | static bool read_long (int f, zlong *result) | ||
94 | { | ||
95 | int a, b, c, d; | ||
96 | |||
97 | if ((a = get_c (f)) == EOF) return FALSE; | ||
98 | if ((b = get_c (f)) == EOF) return FALSE; | ||
99 | if ((c = get_c (f)) == EOF) return FALSE; | ||
100 | if ((d = get_c (f)) == EOF) return FALSE; | ||
101 | |||
102 | *result = ((zlong) a << 24) | ((zlong) b << 16) | | ||
103 | ((zlong) c << 8) | (zlong) d; | ||
104 | return TRUE; | ||
105 | } | ||
106 | |||
107 | /* | ||
108 | * Restore a saved game using Quetzal format. Return 2 if OK, 0 if an error | ||
109 | * occurred before any damage was done, -1 on a fatal error. | ||
110 | */ | ||
111 | |||
112 | zword restore_quetzal (int svf, int stf) | ||
113 | { | ||
114 | zlong ifzslen, currlen, tmpl; | ||
115 | zlong pc; | ||
116 | zword i, tmpw; | ||
117 | zword fatal = 0; /* Set to -1 when errors must be fatal. */ | ||
118 | zbyte skip, progress = GOT_NONE; | ||
119 | int x, y; | ||
120 | |||
121 | /* Check it's really an `IFZS' file. */ | ||
122 | if (!read_long (svf, &tmpl) | ||
123 | || !read_long (svf, &ifzslen) | ||
124 | || !read_long (svf, &currlen)) return 0; | ||
125 | if (tmpl != ID_FORM || currlen != ID_IFZS) | ||
126 | { | ||
127 | print_string ("This is not a saved game file!\n"); | ||
128 | return 0; | ||
129 | } | ||
130 | if ((ifzslen & 1) || ifzslen<4) /* Sanity checks. */ return 0; | ||
131 | ifzslen -= 4; | ||
132 | |||
133 | /* Read each chunk and process it. */ | ||
134 | while (ifzslen > 0) | ||
135 | { | ||
136 | /* Read chunk header. */ | ||
137 | if (ifzslen < 8) /* Couldn't contain a chunk. */ return 0; | ||
138 | if (!read_long (svf, &tmpl) | ||
139 | || !read_long (svf, &currlen)) return 0; | ||
140 | ifzslen -= 8; /* Reduce remaining by size of header. */ | ||
141 | |||
142 | /* Handle chunk body. */ | ||
143 | if (ifzslen < currlen) /* Chunk goes past EOF?! */ return 0; | ||
144 | skip = currlen & 1; | ||
145 | ifzslen -= currlen + (zlong) skip; | ||
146 | |||
147 | switch (tmpl) | ||
148 | { | ||
149 | /* `IFhd' header chunk; must be first in file. */ | ||
150 | case ID_IFhd: | ||
151 | if (progress & GOT_HEADER) | ||
152 | { | ||
153 | print_string ("Save file has two IFZS chunks!\n"); | ||
154 | return fatal; | ||
155 | } | ||
156 | progress |= GOT_HEADER; | ||
157 | if (currlen < 13 | ||
158 | || !read_word (svf, &tmpw)) return fatal; | ||
159 | if (tmpw != h_release) | ||
160 | progress = GOT_ERROR; | ||
161 | |||
162 | for (i=H_SERIAL; i<H_SERIAL+6; ++i) | ||
163 | { | ||
164 | if ((x = get_c (svf)) == EOF) return fatal; | ||
165 | if (x != zmp[i]) | ||
166 | progress = GOT_ERROR; | ||
167 | } | ||
168 | |||
169 | if (!read_word (svf, &tmpw)) return fatal; | ||
170 | if (tmpw != h_checksum) | ||
171 | progress = GOT_ERROR; | ||
172 | |||
173 | if (progress & GOT_ERROR) | ||
174 | { | ||
175 | print_string ("File was not saved from this story!\n"); | ||
176 | return fatal; | ||
177 | } | ||
178 | if ((x = get_c (svf)) == EOF) return fatal; | ||
179 | pc = (zlong) x << 16; | ||
180 | if ((x = get_c (svf)) == EOF) return fatal; | ||
181 | pc |= (zlong) x << 8; | ||
182 | if ((x = get_c (svf)) == EOF) return fatal; | ||
183 | pc |= (zlong) x; | ||
184 | fatal = -1; /* Setting PC means errors must be fatal. */ | ||
185 | SET_PC (pc); | ||
186 | |||
187 | for (i=13; i<currlen; ++i) | ||
188 | (void) get_c (svf); /* Skip rest of chunk. */ | ||
189 | break; | ||
190 | /* `Stks' stacks chunk; restoring this is quite complex. ;) */ | ||
191 | case ID_Stks: | ||
192 | if (progress & GOT_STACK) | ||
193 | { | ||
194 | print_string ("File contains two stack chunks!\n"); | ||
195 | break; | ||
196 | } | ||
197 | progress |= GOT_STACK; | ||
198 | |||
199 | fatal = -1; /* Setting SP means errors must be fatal. */ | ||
200 | sp = stack + STACK_SIZE; | ||
201 | |||
202 | /* | ||
203 | * All versions other than V6 may use evaluation stack outside | ||
204 | * any function context. As a result a faked function context | ||
205 | * will be present in the file here. We skip this context, but | ||
206 | * load the associated stack onto the stack proper... | ||
207 | */ | ||
208 | if (h_version != V6) | ||
209 | { | ||
210 | if (currlen < 8) return fatal; | ||
211 | for (i=0; i<6; ++i) | ||
212 | if (get_c (svf) != 0) return fatal; | ||
213 | if (!read_word (svf, &tmpw)) return fatal; | ||
214 | if (tmpw > STACK_SIZE) | ||
215 | { | ||
216 | print_string ("Save-file has too much stack (and I can't cope).\n"); | ||
217 | return fatal; | ||
218 | } | ||
219 | currlen -= 8; | ||
220 | if ((signed)currlen < tmpw*2) return fatal; | ||
221 | for (i=0; i<tmpw; ++i) | ||
222 | if (!read_word (svf, --sp)) return fatal; | ||
223 | currlen -= tmpw*2; | ||
224 | } | ||
225 | |||
226 | /* We now proceed to load the main block of stack frames. */ | ||
227 | for (fp = stack+STACK_SIZE, frame_count = 0; | ||
228 | currlen > 0; | ||
229 | currlen -= 8, ++frame_count) | ||
230 | { | ||
231 | if (currlen < 8) return fatal; | ||
232 | if (sp - stack < 4) /* No space for frame. */ | ||
233 | { | ||
234 | print_string ("Save-file has too much stack (and I can't cope).\n"); | ||
235 | return fatal; | ||
236 | } | ||
237 | |||
238 | /* Read PC, procedure flag and formal param count. */ | ||
239 | if (!read_long (svf, &tmpl)) return fatal; | ||
240 | y = (int) (tmpl & 0x0F); /* Number of formals. */ | ||
241 | tmpw = y << 8; | ||
242 | |||
243 | /* Read result variable. */ | ||
244 | if ((x = get_c (svf)) == EOF) return fatal; | ||
245 | |||
246 | /* Check the procedure flag... */ | ||
247 | if (tmpl & 0x10) | ||
248 | { | ||
249 | tmpw |= 0x1000; /* It's a procedure. */ | ||
250 | tmpl >>= 8; /* Shift to get PC value. */ | ||
251 | } | ||
252 | else | ||
253 | { | ||
254 | /* Functions have type 0, so no need to or anything. */ | ||
255 | tmpl >>= 8; /* Shift to get PC value. */ | ||
256 | --tmpl; /* Point at result byte. */ | ||
257 | /* Sanity check on result variable... */ | ||
258 | if (zmp[tmpl] != (zbyte) x) | ||
259 | { | ||
260 | print_string ("Save-file has wrong variable number on stack (possibly wrong game version?)\n"); | ||
261 | return fatal; | ||
262 | } | ||
263 | } | ||
264 | *--sp = (zword) (tmpl >> 9); /* High part of PC */ | ||
265 | *--sp = (zword) (tmpl & 0x1FF); /* Low part of PC */ | ||
266 | *--sp = (zword) (fp - stack - 1); /* FP */ | ||
267 | |||
268 | /* Read and process argument mask. */ | ||
269 | if ((x = get_c (svf)) == EOF) return fatal; | ||
270 | ++x; /* Should now be a power of 2 */ | ||
271 | for (i=0; i<8; ++i) | ||
272 | if (x & (1<<i)) | ||
273 | break; | ||
274 | if (x ^ (1<<i)) /* Not a power of 2 */ | ||
275 | { | ||
276 | print_string ("Save-file uses incomplete argument lists (which I can't handle)\n"); | ||
277 | return fatal; | ||
278 | } | ||
279 | *--sp = tmpw | i; | ||
280 | fp = sp; /* FP for next frame. */ | ||
281 | |||
282 | /* Read amount of eval stack used. */ | ||
283 | if (!read_word (svf, &tmpw)) return fatal; | ||
284 | |||
285 | tmpw += y; /* Amount of stack + number of locals. */ | ||
286 | if (sp - stack <= tmpw) | ||
287 | { | ||
288 | print_string ("Save-file has too much stack (and I can't cope).\n"); | ||
289 | return fatal; | ||
290 | } | ||
291 | if ((signed)currlen < tmpw*2) return fatal; | ||
292 | for (i=0; i<tmpw; ++i) | ||
293 | if (!read_word (svf, --sp)) return fatal; | ||
294 | currlen -= tmpw*2; | ||
295 | } | ||
296 | /* End of `Stks' processing... */ | ||
297 | break; | ||
298 | /* Any more special chunk types must go in HERE or ABOVE. */ | ||
299 | /* `CMem' compressed memory chunk; uncompress it. */ | ||
300 | case ID_CMem: | ||
301 | if (!(progress & GOT_MEMORY)) /* Don't complain if two. */ | ||
302 | { | ||
303 | (void) fseek (stf, 0, SEEK_SET); | ||
304 | i=0; /* Bytes written to data area. */ | ||
305 | for (; currlen > 0; --currlen) | ||
306 | { | ||
307 | if ((x = get_c (svf)) == EOF) return fatal; | ||
308 | if (x == 0) /* Start run. */ | ||
309 | { | ||
310 | /* Check for bogus run. */ | ||
311 | if (currlen < 2) | ||
312 | { | ||
313 | print_string ("File contains bogus `CMem' chunk.\n"); | ||
314 | for (; currlen > 0; --currlen) | ||
315 | (void) get_c (svf); /* Skip rest. */ | ||
316 | currlen = 1; | ||
317 | i = 0xFFFF; | ||
318 | break; /* Keep going; may be a `UMem' too. */ | ||
319 | } | ||
320 | /* Copy story file to memory during the run. */ | ||
321 | --currlen; | ||
322 | if ((x = get_c (svf)) == EOF) return fatal; | ||
323 | for (; x >= 0 && i<h_dynamic_size; --x, ++i) | ||
324 | if ((y = get_c (stf)) == EOF) return fatal; | ||
325 | else | ||
326 | zmp[i] = (zbyte) y; | ||
327 | } | ||
328 | else /* Not a run. */ | ||
329 | { | ||
330 | if ((y = get_c (stf)) == EOF) return fatal; | ||
331 | zmp[i] = (zbyte) (x ^ y); | ||
332 | ++i; | ||
333 | } | ||
334 | /* Make sure we don't load too much. */ | ||
335 | if (i > h_dynamic_size) | ||
336 | { | ||
337 | print_string ("warning: `CMem' chunk too long!\n"); | ||
338 | for (; currlen > 1; --currlen) | ||
339 | (void) get_c (svf); /* Skip rest. */ | ||
340 | break; /* Keep going; there may be a `UMem' too. */ | ||
341 | } | ||
342 | } | ||
343 | /* If chunk is short, assume a run. */ | ||
344 | for (; i<h_dynamic_size; ++i) | ||
345 | if ((y = get_c (stf)) == EOF) return fatal; | ||
346 | else | ||
347 | zmp[i] = (zbyte) y; | ||
348 | if (currlen == 0) | ||
349 | progress |= GOT_MEMORY; /* Only if succeeded. */ | ||
350 | break; | ||
351 | } | ||
352 | /* Fall right thru (to default) if already GOT_MEMORY */ | ||
353 | /* `UMem' uncompressed memory chunk; load it. */ | ||
354 | case ID_UMem: | ||
355 | if (!(progress & GOT_MEMORY)) /* Don't complain if two. */ | ||
356 | { | ||
357 | /* Must be exactly the right size. */ | ||
358 | if (currlen == h_dynamic_size) | ||
359 | { | ||
360 | if (fread (zmp, currlen, 1, svf) == 1) | ||
361 | { | ||
362 | progress |= GOT_MEMORY; /* Only on success. */ | ||
363 | break; | ||
364 | } | ||
365 | } | ||
366 | else | ||
367 | print_string ("`UMem' chunk wrong size!\n"); | ||
368 | /* Fall into default action (skip chunk) on errors. */ | ||
369 | } | ||
370 | /* Fall thru (to default) if already GOT_MEMORY */ | ||
371 | /* Unrecognised chunk type; skip it. */ | ||
372 | default: | ||
373 | (void) fseek (svf, currlen, SEEK_CUR); /* Skip chunk. */ | ||
374 | break; | ||
375 | } | ||
376 | if (skip) | ||
377 | (void) get_c (svf); /* Skip pad byte. */ | ||
378 | } | ||
379 | |||
380 | /* | ||
381 | * We've reached the end of the file. For the restoration to have been a | ||
382 | * success, we must have had one of each of the required chunks. | ||
383 | */ | ||
384 | if (!(progress & GOT_HEADER)) | ||
385 | print_string ("error: no valid header (`IFhd') chunk in file.\n"); | ||
386 | if (!(progress & GOT_STACK)) | ||
387 | print_string ("error: no valid stack (`Stks') chunk in file.\n"); | ||
388 | if (!(progress & GOT_MEMORY)) | ||
389 | print_string ("error: no valid memory (`CMem' or `UMem') chunk in file.\n"); | ||
390 | |||
391 | return (progress == GOT_ALL ? 2 : fatal); | ||
392 | } | ||
393 | |||
394 | /* | ||
395 | * Save a game using Quetzal format. Return 1 if OK, 0 if failed. | ||
396 | */ | ||
397 | |||
398 | zword save_quetzal (int svf, int stf) | ||
399 | { | ||
400 | zlong ifzslen = 0, cmemlen = 0, stkslen = 0; | ||
401 | zlong pc; | ||
402 | zword i, j, n; | ||
403 | zword nvars, nargs, nstk, *p; | ||
404 | zbyte var; | ||
405 | long cmempos, stkspos; | ||
406 | int c; | ||
407 | |||
408 | /* Write `IFZS' header. */ | ||
409 | if (!write_chnk (svf, ID_FORM, 0)) return 0; | ||
410 | if (!write_long (svf, ID_IFZS)) return 0; | ||
411 | |||
412 | /* Write `IFhd' chunk. */ | ||
413 | GET_PC (pc); | ||
414 | if (!write_chnk (svf, ID_IFhd, 13)) return 0; | ||
415 | if (!write_word (svf, h_release)) return 0; | ||
416 | for (i=H_SERIAL; i<H_SERIAL+6; ++i) | ||
417 | if (!write_byte (svf, zmp[i])) return 0; | ||
418 | if (!write_word (svf, h_checksum)) return 0; | ||
419 | if (!write_long (svf, pc << 8)) /* Includes pad. */ return 0; | ||
420 | |||
421 | /* Write `CMem' chunk. */ | ||
422 | if ((cmempos = ftell (svf)) < 0) return 0; | ||
423 | if (!write_chnk (svf, ID_CMem, 0)) return 0; | ||
424 | (void) fseek (stf, 0, SEEK_SET); | ||
425 | /* j holds current run length. */ | ||
426 | for (i=0, j=0, cmemlen=0; i < h_dynamic_size; ++i) | ||
427 | { | ||
428 | if ((c = get_c (stf)) == EOF) return 0; | ||
429 | c ^= (int) zmp[i]; | ||
430 | if (c == 0) | ||
431 | ++j; /* It's a run of equal bytes. */ | ||
432 | else | ||
433 | { | ||
434 | /* Write out any run there may be. */ | ||
435 | if (j > 0) | ||
436 | { | ||
437 | for (; j > 0x100; j -= 0x100) | ||
438 | { | ||
439 | if (!write_run (svf, 0xFF)) return 0; | ||
440 | cmemlen += 2; | ||
441 | } | ||
442 | if (!write_run (svf, j-1)) return 0; | ||
443 | cmemlen += 2; | ||
444 | j = 0; | ||
445 | } | ||
446 | /* Any runs are now written. Write this (nonzero) byte. */ | ||
447 | if (!write_byte (svf, (zbyte) c)) return 0; | ||
448 | ++cmemlen; | ||
449 | } | ||
450 | } | ||
451 | /* | ||
452 | * Reached end of dynamic memory. We ignore any unwritten run there may be | ||
453 | * at this point. | ||
454 | */ | ||
455 | if (cmemlen & 1) /* Chunk length must be even. */ | ||
456 | if (!write_byte (svf, 0)) return 0; | ||
457 | |||
458 | /* Write `Stks' chunk. You are not expected to understand this. ;) */ | ||
459 | if ((stkspos = ftell (svf)) < 0) return 0; | ||
460 | if (!write_chnk (svf, ID_Stks, 0)) return 0; | ||
461 | |||
462 | /* | ||
463 | * We construct a list of frame indices, most recent first, in `frames'. | ||
464 | * These indices are the offsets into the `stack' array of the word before | ||
465 | * the first word pushed in each frame. | ||
466 | */ | ||
467 | frames[0] = sp - stack; /* The frame we'd get by doing a call now. */ | ||
468 | for (i = fp - stack + 4, n=0; i < STACK_SIZE+4; i = stack[i-3] + 5) | ||
469 | frames[++n] = i; | ||
470 | |||
471 | /* | ||
472 | * All versions other than V6 can use evaluation stack outside a function | ||
473 | * context. We write a faked stack frame (most fields zero) to cater for | ||
474 | * this. | ||
475 | */ | ||
476 | if (h_version != V6) | ||
477 | { | ||
478 | for (i=0; i<6; ++i) | ||
479 | if (!write_byte (svf, 0)) return 0; | ||
480 | nstk = STACK_SIZE - frames[n]; | ||
481 | if (!write_word (svf, nstk)) return 0; | ||
482 | for (j=STACK_SIZE-1; j >= frames[n]; --j) | ||
483 | if (!write_word (svf, stack[j])) return 0; | ||
484 | stkslen = 8 + 2*nstk; | ||
485 | } | ||
486 | |||
487 | /* Write out the rest of the stack frames. */ | ||
488 | for (i=n; i>0; --i) | ||
489 | { | ||
490 | p = stack + frames[i] - 4; /* Points to call frame. */ | ||
491 | nvars = (p[0] & 0x0F00) >> 8; | ||
492 | nargs = p[0] & 0x00FF; | ||
493 | nstk = frames[i] - frames[i-1] - nvars - 4; | ||
494 | pc = ((zlong) p[3] << 9) | p[2]; | ||
495 | |||
496 | switch (p[0] & 0xF000) /* Check type of call. */ | ||
497 | { | ||
498 | case 0x0000: /* Function. */ | ||
499 | var = zmp[pc]; | ||
500 | pc = ((pc + 1) << 8) | nvars; | ||
501 | break; | ||
502 | case 0x1000: /* Procedure. */ | ||
503 | var = 0; | ||
504 | pc = (pc << 8) | 0x10 | nvars; /* Set procedure flag. */ | ||
505 | break; | ||
506 | /* case 0x2000: */ | ||
507 | default: | ||
508 | runtime_error (ERR_SAVE_IN_INTER); | ||
509 | return 0; | ||
510 | } | ||
511 | if (nargs != 0) | ||
512 | nargs = (1 << nargs) - 1; /* Make args into bitmap. */ | ||
513 | |||
514 | /* Write the main part of the frame... */ | ||
515 | if (!write_long (svf, pc) | ||
516 | || !write_byte (svf, var) | ||
517 | || !write_byte (svf, nargs) | ||
518 | || !write_word (svf, nstk)) return 0; | ||
519 | |||
520 | /* Write the variables and eval stack. */ | ||
521 | for (j=0, ++p; j<nvars+nstk; ++j, --p) | ||
522 | if (!write_word (svf, *p)) return 0; | ||
523 | |||
524 | /* Calculate length written thus far. */ | ||
525 | stkslen += 8 + 2 * (nvars + nstk); | ||
526 | } | ||
527 | |||
528 | /* Fill in variable chunk lengths. */ | ||
529 | ifzslen = 3*8 + 4 + 14 + cmemlen + stkslen; | ||
530 | if (cmemlen & 1) | ||
531 | ++ifzslen; | ||
532 | (void) fseek (svf, 4, SEEK_SET); | ||
533 | if (!write_long (svf, ifzslen)) return 0; | ||
534 | (void) fseek (svf, cmempos+4, SEEK_SET); | ||
535 | if (!write_long (svf, cmemlen)) return 0; | ||
536 | (void) fseek (svf, stkspos+4, SEEK_SET); | ||
537 | if (!write_long (svf, stkslen)) return 0; | ||
538 | |||
539 | /* After all that, still nothing went wrong! */ | ||
540 | return 1; | ||
541 | } | ||