Update Andrew Plotkin's unit tests
[projects/chimara/chimara.git] / interpreters / frotz / object.c
1 /* object.c - Object manipulation opcodes
2  * Copyright (c) 1995-1997 Stefan Jokisch
3  *
4  * This file is part of Frotz.
5  *
6  * Frotz is free software; you can redistribute it and/or modify
7  * it under the terms of the GNU General Public License as published by
8  * the Free Software Foundation; either version 2 of the License, or
9  * (at your option) any later version.
10  *
11  * Frotz is distributed in the hope that it will be useful,
12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14  * GNU General Public License for more details.
15  *
16  * You should have received a copy of the GNU General Public License
17  * along with this program; if not, write to the Free Software
18  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
19  */
20
21 #include "frotz.h"
22
23 #define MAX_OBJECT 2000
24
25 #define O1_PARENT 4
26 #define O1_SIBLING 5
27 #define O1_CHILD 6
28 #define O1_PROPERTY_OFFSET 7
29 #define O1_SIZE 9
30
31 #define O4_PARENT 6
32 #define O4_SIBLING 8
33 #define O4_CHILD 10
34 #define O4_PROPERTY_OFFSET 12
35 #define O4_SIZE 14
36
37 /*
38  * object_address
39  *
40  * Calculate the address of an object.
41  *
42  */
43
44 static zword object_address (zword obj)
45 {
46     /* Check object number */
47
48     if (obj > ((h_version <= V3) ? 255 : MAX_OBJECT)) {
49         print_string("@Attempt to address illegal object ");
50         print_num(obj);
51         print_string(".  This is normally fatal.");
52         new_line();
53         runtime_error (ERR_ILL_OBJ);
54     }
55
56     /* Return object address */
57
58     if (h_version <= V3)
59         return h_objects + ((obj - 1) * O1_SIZE + 62);
60     else
61         return h_objects + ((obj - 1) * O4_SIZE + 126);
62
63 }/* object_address */
64
65 /*
66  * object_name
67  *
68  * Return the address of the given object's name.
69  *
70  */
71
72 zword object_name (zword object)
73 {
74     zword obj_addr;
75     zword name_addr;
76
77     obj_addr = object_address (object);
78
79     /* The object name address is found at the start of the properties */
80
81     if (h_version <= V3)
82         obj_addr += O1_PROPERTY_OFFSET;
83     else
84         obj_addr += O4_PROPERTY_OFFSET;
85
86     LOW_WORD (obj_addr, name_addr)
87
88     return name_addr;
89
90 }/* object_name */
91
92 /*
93  * first_property
94  *
95  * Calculate the start address of the property list associated with
96  * an object.
97  *
98  */
99
100 static zword first_property (zword obj)
101 {
102     zword prop_addr;
103     zbyte size;
104
105     /* Fetch address of object name */
106
107     prop_addr = object_name (obj);
108
109     /* Get length of object name */
110
111     LOW_BYTE (prop_addr, size)
112
113     /* Add name length to pointer */
114
115     return prop_addr + 1 + 2 * size;
116
117 }/* first_property */
118
119 /*
120  * next_property
121  *
122  * Calculate the address of the next property in a property list.
123  *
124  */
125
126 static zword next_property (zword prop_addr)
127 {
128     zbyte value;
129
130     /* Load the current property id */
131
132     LOW_BYTE (prop_addr, value)
133     prop_addr++;
134
135     /* Calculate the length of this property */
136
137     if (h_version <= V3)
138         value >>= 5;
139     else if (!(value & 0x80))
140         value >>= 6;
141     else {
142
143         LOW_BYTE (prop_addr, value)
144         value &= 0x3f;
145
146         if (value == 0) value = 64;        /* demanded by Spec 1.0 */
147
148     }
149
150     /* Add property length to current property pointer */
151
152     return prop_addr + value + 1;
153
154 }/* next_property */
155
156 /*
157  * unlink_object
158  *
159  * Unlink an object from its parent and siblings.
160  *
161  */
162
163 static void unlink_object (zword object)
164 {
165     zword obj_addr;
166     zword parent_addr;
167     zword sibling_addr;
168
169     if (object == 0) {
170         runtime_error (ERR_REMOVE_OBJECT_0);
171         return;
172     }
173
174     obj_addr = object_address (object);
175
176     if (h_version <= V3) {
177
178         zbyte parent;
179         zbyte younger_sibling;
180         zbyte older_sibling;
181         zbyte zero = 0;
182
183         /* Get parent of object, and return if no parent */
184
185         obj_addr += O1_PARENT;
186         LOW_BYTE (obj_addr, parent)
187         if (!parent)
188             return;
189
190         /* Get (older) sibling of object and set both parent and sibling
191            pointers to 0 */
192
193         SET_BYTE (obj_addr, zero)
194         obj_addr += O1_SIBLING - O1_PARENT;
195         LOW_BYTE (obj_addr, older_sibling)
196         SET_BYTE (obj_addr, zero)
197
198         /* Get first child of parent (the youngest sibling of the object) */
199
200         parent_addr = object_address (parent) + O1_CHILD;
201         LOW_BYTE (parent_addr, younger_sibling)
202
203         /* Remove object from the list of siblings */
204
205         if (younger_sibling == object)
206             SET_BYTE (parent_addr, older_sibling)
207         else {
208             do {
209                 sibling_addr = object_address (younger_sibling) + O1_SIBLING;
210                 LOW_BYTE (sibling_addr, younger_sibling)
211             } while (younger_sibling != object);
212             SET_BYTE (sibling_addr, older_sibling)
213         }
214
215     } else {
216
217         zword parent;
218         zword younger_sibling;
219         zword older_sibling;
220         zword zero = 0;
221
222         /* Get parent of object, and return if no parent */
223
224         obj_addr += O4_PARENT;
225         LOW_WORD (obj_addr, parent)
226         if (!parent)
227             return;
228
229         /* Get (older) sibling of object and set both parent and sibling
230            pointers to 0 */
231
232         SET_WORD (obj_addr, zero)
233         obj_addr += O4_SIBLING - O4_PARENT;
234         LOW_WORD (obj_addr, older_sibling)
235         SET_WORD (obj_addr, zero)
236
237         /* Get first child of parent (the youngest sibling of the object) */
238
239         parent_addr = object_address (parent) + O4_CHILD;
240         LOW_WORD (parent_addr, younger_sibling)
241
242         /* Remove object from the list of siblings */
243
244         if (younger_sibling == object)
245             SET_WORD (parent_addr, older_sibling)
246         else {
247             do {
248                 sibling_addr = object_address (younger_sibling) + O4_SIBLING;
249                 LOW_WORD (sibling_addr, younger_sibling)
250             } while (younger_sibling != object);
251             SET_WORD (sibling_addr, older_sibling)
252         }
253
254     }
255
256 }/* unlink_object */
257
258 /*
259  * z_clear_attr, clear an object attribute.
260  *
261  *        zargs[0] = object
262  *        zargs[1] = number of attribute to be cleared
263  *
264  */
265
266 void z_clear_attr (void)
267 {
268     zword obj_addr;
269     zbyte value;
270
271     if (story_id == SHERLOCK)
272         if (zargs[1] == 48)
273             return;
274
275     if (zargs[1] > ((h_version <= V3) ? 31 : 47))
276         runtime_error (ERR_ILL_ATTR);
277
278     /* If we are monitoring attribute assignment display a short note */
279
280     if (option_attribute_assignment) {
281         stream_mssg_on ();
282         print_string ("@clear_attr ");
283         print_object (zargs[0]);
284         print_string (" ");
285         print_num (zargs[1]);
286         stream_mssg_off ();
287     }
288
289     if (zargs[0] == 0) {
290         runtime_error (ERR_CLEAR_ATTR_0);
291         return;
292     }
293
294     /* Get attribute address */
295
296     obj_addr = object_address (zargs[0]) + zargs[1] / 8;
297
298     /* Clear attribute bit */
299
300     LOW_BYTE (obj_addr, value)
301     value &= ~(0x80 >> (zargs[1] & 7));
302     SET_BYTE (obj_addr, value)
303
304 }/* z_clear_attr */
305
306 /*
307  * z_jin, branch if the first object is inside the second.
308  *
309  *        zargs[0] = first object
310  *        zargs[1] = second object
311  *
312  */
313
314 void z_jin (void)
315 {
316     zword obj_addr;
317
318     /* If we are monitoring object locating display a short note */
319
320     if (option_object_locating) {
321         stream_mssg_on ();
322         print_string ("@jin ");
323         print_object (zargs[0]);
324         print_string (" ");
325         print_object (zargs[1]);
326         stream_mssg_off ();
327     }
328
329     if (zargs[0] == 0) {
330         runtime_error (ERR_JIN_0);
331         branch (0 == zargs[1]);
332         return;
333     }
334
335     obj_addr = object_address (zargs[0]);
336
337     if (h_version <= V3) {
338
339         zbyte parent;
340
341         /* Get parent id from object */
342
343         obj_addr += O1_PARENT;
344         LOW_BYTE (obj_addr, parent)
345
346         /* Branch if the parent is obj2 */
347
348         branch (parent == zargs[1]);
349
350     } else {
351
352         zword parent;
353
354         /* Get parent id from object */
355
356         obj_addr += O4_PARENT;
357         LOW_WORD (obj_addr, parent)
358
359         /* Branch if the parent is obj2 */
360
361         branch (parent == zargs[1]);
362
363     }
364
365 }/* z_jin */
366
367 /*
368  * z_get_child, store the child of an object.
369  *
370  *        zargs[0] = object
371  *
372  */
373
374 void z_get_child (void)
375 {
376     zword obj_addr;
377
378     /* If we are monitoring object locating display a short note */
379
380     if (option_object_locating) {
381         stream_mssg_on ();
382         print_string ("@get_child ");
383         print_object (zargs[0]);
384         stream_mssg_off ();
385     }
386
387     if (zargs[0] == 0) {
388         runtime_error (ERR_GET_CHILD_0);
389         store (0);
390         branch (FALSE);
391         return;
392     }
393
394     obj_addr = object_address (zargs[0]);
395
396     if (h_version <= V3) {
397
398         zbyte child;
399
400         /* Get child id from object */
401
402         obj_addr += O1_CHILD;
403         LOW_BYTE (obj_addr, child)
404
405         /* Store child id and branch */
406
407         store (child);
408         branch (child);
409
410     } else {
411
412         zword child;
413
414         /* Get child id from object */
415
416         obj_addr += O4_CHILD;
417         LOW_WORD (obj_addr, child)
418
419         /* Store child id and branch */
420
421         store (child);
422         branch (child);
423
424     }
425
426 }/* z_get_child */
427
428 /*
429  * z_get_next_prop, store the number of the first or next property.
430  *
431  *        zargs[0] = object
432  *        zargs[1] = address of current property (0 gets the first property)
433  *
434  */
435
436 void z_get_next_prop (void)
437 {
438     zword prop_addr;
439     zbyte value;
440     zbyte mask;
441
442     if (zargs[0] == 0) {
443         runtime_error (ERR_GET_NEXT_PROP_0);
444         store (0);
445         return;
446     }
447
448     /* Property id is in bottom five (six) bits */
449
450     mask = (h_version <= V3) ? 0x1f : 0x3f;
451
452     /* Load address of first property */
453
454     prop_addr = first_property (zargs[0]);
455
456     if (zargs[1] != 0) {
457
458         /* Scan down the property list */
459
460         do {
461             LOW_BYTE (prop_addr, value)
462             prop_addr = next_property (prop_addr);
463         } while ((value & mask) > zargs[1]);
464
465         /* Exit if the property does not exist */
466
467         if ((value & mask) != zargs[1])
468             runtime_error (ERR_NO_PROP);
469
470     }
471
472     /* Return the property id */
473
474     LOW_BYTE (prop_addr, value)
475     store ((zword) (value & mask));
476
477 }/* z_get_next_prop */
478
479 /*
480  * z_get_parent, store the parent of an object.
481  *
482  *        zargs[0] = object
483  *
484  */
485
486 void z_get_parent (void)
487 {
488     zword obj_addr;
489
490     /* If we are monitoring object locating display a short note */
491
492     if (option_object_locating) {
493         stream_mssg_on ();
494         print_string ("@get_parent ");
495         print_object (zargs[0]);
496         stream_mssg_off ();
497     }
498
499     if (zargs[0] == 0) {
500         runtime_error (ERR_GET_PARENT_0);
501         store (0);
502         return;
503     }
504
505     obj_addr = object_address (zargs[0]);
506
507     if (h_version <= V3) {
508
509         zbyte parent;
510
511         /* Get parent id from object */
512
513         obj_addr += O1_PARENT;
514         LOW_BYTE (obj_addr, parent)
515
516         /* Store parent */
517
518         store (parent);
519
520     } else {
521
522         zword parent;
523
524         /* Get parent id from object */
525
526         obj_addr += O4_PARENT;
527         LOW_WORD (obj_addr, parent)
528
529         /* Store parent */
530
531         store (parent);
532
533     }
534
535 }/* z_get_parent */
536
537 /*
538  * z_get_prop, store the value of an object property.
539  *
540  *        zargs[0] = object
541  *        zargs[1] = number of property to be examined
542  *
543  */
544
545 void z_get_prop (void)
546 {
547     zword prop_addr;
548     zword wprop_val;
549     zbyte bprop_val;
550     zbyte value;
551     zbyte mask;
552
553     if (zargs[0] == 0) {
554         runtime_error (ERR_GET_PROP_0);
555         store (0);
556         return;
557     }
558
559     /* Property id is in bottom five (six) bits */
560
561     mask = (h_version <= V3) ? 0x1f : 0x3f;
562
563     /* Load address of first property */
564
565     prop_addr = first_property (zargs[0]);
566
567     /* Scan down the property list */
568
569     for (;;) {
570         LOW_BYTE (prop_addr, value)
571         if ((value & mask) <= zargs[1])
572             break;
573         prop_addr = next_property (prop_addr);
574     }
575
576     if ((value & mask) == zargs[1]) {        /* property found */
577
578         /* Load property (byte or word sized) */
579
580         prop_addr++;
581
582         if ((h_version <= V3 && !(value & 0xe0)) || (h_version >= V4 && !(value & 0xc0))) {
583
584             LOW_BYTE (prop_addr, bprop_val)
585             wprop_val = bprop_val;
586
587         } else LOW_WORD (prop_addr, wprop_val)
588
589     } else {        /* property not found */
590
591         /* Load default value */
592
593         prop_addr = h_objects + 2 * (zargs[1] - 1);
594         LOW_WORD (prop_addr, wprop_val)
595
596     }
597
598     /* Store the property value */
599
600     store (wprop_val);
601
602 }/* z_get_prop */
603
604 /*
605  * z_get_prop_addr, store the address of an object property.
606  *
607  *        zargs[0] = object
608  *        zargs[1] = number of property to be examined
609  *
610  */
611
612 void z_get_prop_addr (void)
613 {
614     zword prop_addr;
615     zbyte value;
616     zbyte mask;
617
618     if (zargs[0] == 0) {
619         runtime_error (ERR_GET_PROP_ADDR_0);
620         store (0);
621         return;
622     }
623
624     if (story_id == BEYOND_ZORK)
625         if (zargs[0] > MAX_OBJECT)
626             { store (0); return; }
627
628     /* Property id is in bottom five (six) bits */
629
630     mask = (h_version <= V3) ? 0x1f : 0x3f;
631
632     /* Load address of first property */
633
634     prop_addr = first_property (zargs[0]);
635
636     /* Scan down the property list */
637
638     for (;;) {
639         LOW_BYTE (prop_addr, value)
640         if ((value & mask) <= zargs[1])
641             break;
642         prop_addr = next_property (prop_addr);
643     }
644
645     /* Calculate the property address or return zero */
646
647     if ((value & mask) == zargs[1]) {
648
649         if (h_version >= V4 && (value & 0x80))
650             prop_addr++;
651         store ((zword) (prop_addr + 1));
652
653     } else store (0);
654
655 }/* z_get_prop_addr */
656
657 /*
658  * z_get_prop_len, store the length of an object property.
659  *
660  *         zargs[0] = address of property to be examined
661  *
662  */
663
664 void z_get_prop_len (void)
665 {
666     zword addr;
667     zbyte value;
668
669     /* Back up the property pointer to the property id */
670
671     addr = zargs[0] - 1;
672     LOW_BYTE (addr, value)
673
674     /* Calculate length of property */
675
676     if (h_version <= V3)
677         value = (value >> 5) + 1;
678     else if (!(value & 0x80))
679         value = (value >> 6) + 1;
680     else {
681
682         value &= 0x3f;
683
684         if (value == 0) value = 64;        /* demanded by Spec 1.0 */
685
686     }
687
688     /* Store length of property */
689
690     store (value);
691
692 }/* z_get_prop_len */
693
694 /*
695  * z_get_sibling, store the sibling of an object.
696  *
697  *        zargs[0] = object
698  *
699  */
700
701 void z_get_sibling (void)
702 {
703     zword obj_addr;
704
705     if (zargs[0] == 0) {
706         runtime_error (ERR_GET_SIBLING_0);
707         store (0);
708         branch (FALSE);
709         return;
710     }
711
712     obj_addr = object_address (zargs[0]);
713
714     if (h_version <= V3) {
715
716         zbyte sibling;
717
718         /* Get sibling id from object */
719
720         obj_addr += O1_SIBLING;
721         LOW_BYTE (obj_addr, sibling)
722
723         /* Store sibling and branch */
724
725         store (sibling);
726         branch (sibling);
727
728     } else {
729
730         zword sibling;
731
732         /* Get sibling id from object */
733
734         obj_addr += O4_SIBLING;
735         LOW_WORD (obj_addr, sibling)
736
737         /* Store sibling and branch */
738
739         store (sibling);
740         branch (sibling);
741
742     }
743
744 }/* z_get_sibling */
745
746 /*
747  * z_insert_obj, make an object the first child of another object.
748  *
749  *        zargs[0] = object to be moved
750  *        zargs[1] = destination object
751  *
752  */
753
754 void z_insert_obj (void)
755 {
756     zword obj1 = zargs[0];
757     zword obj2 = zargs[1];
758     zword obj1_addr;
759     zword obj2_addr;
760
761     /* If we are monitoring object movements display a short note */
762
763     if (option_object_movement) {
764         stream_mssg_on ();
765         print_string ("@move_obj ");
766         print_object (obj1);
767         print_string (" ");
768         print_object (obj2);
769         stream_mssg_off ();
770     }
771
772     if (obj1 == 0) {
773         runtime_error (ERR_MOVE_OBJECT_0);
774         return;
775     }
776
777     if (obj2 == 0) {
778         runtime_error (ERR_MOVE_OBJECT_TO_0);
779         return;
780     }
781
782     /* Get addresses of both objects */
783
784     obj1_addr = object_address (obj1);
785     obj2_addr = object_address (obj2);
786
787     /* Remove object 1 from current parent */
788
789     unlink_object (obj1);
790
791     /* Make object 1 first child of object 2 */
792
793     if (h_version <= V3) {
794
795         zbyte child;
796
797         obj1_addr += O1_PARENT;
798         SET_BYTE (obj1_addr, obj2)
799         obj2_addr += O1_CHILD;
800         LOW_BYTE (obj2_addr, child)
801         SET_BYTE (obj2_addr, obj1)
802         obj1_addr += O1_SIBLING - O1_PARENT;
803         SET_BYTE (obj1_addr, child)
804
805     } else {
806
807         zword child;
808
809         obj1_addr += O4_PARENT;
810         SET_WORD (obj1_addr, obj2)
811         obj2_addr += O4_CHILD;
812         LOW_WORD (obj2_addr, child)
813         SET_WORD (obj2_addr, obj1)
814         obj1_addr += O4_SIBLING - O4_PARENT;
815         SET_WORD (obj1_addr, child)
816
817     }
818
819 }/* z_insert_obj */
820
821 /*
822  * z_put_prop, set the value of an object property.
823  *
824  *        zargs[0] = object
825  *        zargs[1] = number of property to set
826  *        zargs[2] = value to set property to
827  *
828  */
829
830 void z_put_prop (void)
831 {
832     zword prop_addr;
833     zword value;
834     zbyte mask;
835
836     if (zargs[0] == 0) {
837         runtime_error (ERR_PUT_PROP_0);
838         return;
839     }
840
841     /* Property id is in bottom five or six bits */
842
843     mask = (h_version <= V3) ? 0x1f : 0x3f;
844
845     /* Load address of first property */
846
847     prop_addr = first_property (zargs[0]);
848
849     /* Scan down the property list */
850
851     for (;;) {
852         LOW_BYTE (prop_addr, value)
853         if ((value & mask) <= zargs[1])
854             break;
855         prop_addr = next_property (prop_addr);
856     }
857
858     /* Exit if the property does not exist */
859
860     if ((value & mask) != zargs[1])
861         runtime_error (ERR_NO_PROP);
862
863     /* Store the new property value (byte or word sized) */
864
865     prop_addr++;
866
867     if ((h_version <= V3 && !(value & 0xe0)) || (h_version >= V4 && !(value & 0xc0))) {
868         zbyte v = zargs[2];
869         SET_BYTE (prop_addr, v)
870     } else {
871         zword v = zargs[2];
872         SET_WORD (prop_addr, v)
873     }
874
875 }/* z_put_prop */
876
877 /*
878  * z_remove_obj, unlink an object from its parent and siblings.
879  *
880  *        zargs[0] = object
881  *
882  */
883
884 void z_remove_obj (void)
885 {
886
887     /* If we are monitoring object movements display a short note */
888
889     if (option_object_movement) {
890         stream_mssg_on ();
891         print_string ("@remove_obj ");
892         print_object (zargs[0]);
893         stream_mssg_off ();
894     }
895
896     /* Call unlink_object to do the job */
897
898     unlink_object (zargs[0]);
899
900 }/* z_remove_obj */
901
902 /*
903  * z_set_attr, set an object attribute.
904  *
905  *        zargs[0] = object
906  *        zargs[1] = number of attribute to set
907  *
908  */
909
910 void z_set_attr (void)
911 {
912     zword obj_addr;
913     zbyte value;
914
915     if (story_id == SHERLOCK)
916         if (zargs[1] == 48)
917             return;
918
919     if (zargs[1] > ((h_version <= V3) ? 31 : 47))
920         runtime_error (ERR_ILL_ATTR);
921
922     /* If we are monitoring attribute assignment display a short note */
923
924     if (option_attribute_assignment) {
925         stream_mssg_on ();
926         print_string ("@set_attr ");
927         print_object (zargs[0]);
928         print_string (" ");
929         print_num (zargs[1]);
930         stream_mssg_off ();
931     }
932
933     if (zargs[0] == 0) {
934         runtime_error (ERR_SET_ATTR_0);
935         return;
936     }
937
938     /* Get attribute address */
939
940     obj_addr = object_address (zargs[0]) + zargs[1] / 8;
941
942     /* Load attribute byte */
943
944     LOW_BYTE (obj_addr, value)
945
946     /* Set attribute bit */
947
948     value |= 0x80 >> (zargs[1] & 7);
949
950     /* Store attribute byte */
951
952     SET_BYTE (obj_addr, value)
953
954 }/* z_set_attr */
955
956 /*
957  * z_test_attr, branch if an object attribute is set.
958  *
959  *        zargs[0] = object
960  *        zargs[1] = number of attribute to test
961  *
962  */
963
964 void z_test_attr (void)
965 {
966     zword obj_addr;
967     zbyte value;
968
969     if (zargs[1] > ((h_version <= V3) ? 31 : 47))
970         runtime_error (ERR_ILL_ATTR);
971
972     /* If we are monitoring attribute testing display a short note */
973
974     if (option_attribute_testing) {
975         stream_mssg_on ();
976         print_string ("@test_attr ");
977         print_object (zargs[0]);
978         print_string (" ");
979         print_num (zargs[1]);
980         stream_mssg_off ();
981     }
982
983     if (zargs[0] == 0) {
984         runtime_error (ERR_TEST_ATTR_0);
985         branch (FALSE);
986         return;
987     }
988
989     /* Get attribute address */
990
991     obj_addr = object_address (zargs[0]) + zargs[1] / 8;
992
993     /* Load attribute byte */
994
995     LOW_BYTE (obj_addr, value)
996
997     /* Test attribute */
998
999     branch (value & (0x80 >> (zargs[1] & 7)));
1000
1001 }/* z_test_attr */