1 /* type.c: Built-in and user-defined Scheme types.
2 *
3 * $Id$
4 *
5 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
6 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris
7 *
8 * This software was derived from Elk 1.2, which was Copyright 1987, 1988,
9 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
10 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
11 * between TELES and Nixdorf Microprocessor Engineering, Berlin).
12 *
13 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
14 * owners or individual owners of copyright in this software, grant to any
15 * person or company a worldwide, royalty free, license to
16 *
17 * i) copy this software,
18 * ii) prepare derivative works based on this software,
19 * iii) distribute copies of this software or derivative works,
20 * iv) perform this software, or
21 * v) display this software,
22 *
23 * provided that this notice is not removed and that neither Oliver Laumann
24 * nor Teles nor Nixdorf are deemed to have made any representations as to
25 * the suitability of this software for any purpose nor are held responsible
26 * for any defects of this software.
27 *
28 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
29 */
30
31 #include "config.h"
32
33 #include <string.h>
34
35 #include "kernel.h"
36
37 #define TYPE_GROW 10
38
39 TYPEDESCR *Types;
40 int Num_Types, Max_Type;
41
42 char *builtin_types[] = {
43 "0integer", "1integer" /* bignum */, "1real", "0null", "0boolean",
44 "0unbound", "0special", "0character", "1symbol", "1pair",
45 "1environment", "1string", "1vector", "1primitive", "1compound",
46 "1control-point", "1promise", "1port", "0end-of-file", "1autoload",
47 "1macro", "1!!broken-heart!!",
48 #ifdef GENERATIONAL_GC
49 "0align_8byte", "0freespace",
50 #endif
51 0
52 };
53
Wrong_Type(Object x,register int t)54 void Wrong_Type (Object x, register int t) {
55 Wrong_Type_Combination (x, Types[t].name);
56 }
57
Wrong_Type_Combination(Object x,register char const * name)58 void Wrong_Type_Combination (Object x, register char const *name) {
59 register int t = TYPE(x);
60 char buf[100];
61
62 if (t < 0 || t >= Num_Types)
63 Panic ("bad type1");
64 sprintf (buf, "wrong argument type %s (expected %s)",
65 Types[t].name, name);
66 Primitive_Error (buf);
67 }
68
P_Type(Object x)69 Object P_Type (Object x) {
70 register int t = TYPE(x);
71
72 if (t < 0 || t >= Num_Types)
73 Panic ("bad type2");
74 return Intern (Types[t].name);
75 }
76
Define_Type(register int t,char const * name,int (* size)(),int const_size,int (* eqv)(),int (* equal)(),int (* print)(),int (* visit)())77 int Define_Type (register int t, char const *name,
78 int (*size)(), int const_size, int (*eqv)(), int (*equal)(),
79 int (*print)(), int (*visit)()) {
80 register TYPEDESCR *p;
81
82 Set_Error_Tag ("define-type");
83 if (t != 0)
84 Fatal_Error("first arg of Define_Type() must be 0");
85 if (Num_Types == Max_Type) {
86 Max_Type += TYPE_GROW;
87 Types = (TYPEDESCR *)Safe_Realloc((char *)Types,
88 Max_Type * sizeof(TYPEDESCR));
89 }
90 Disable_Interrupts;
91 p = &Types[Num_Types++];
92 p->haspointer = 1;
93 p->name = name;
94 p->size = size;
95 p->const_size = const_size;
96 p->eqv = eqv;
97 p->equal = equal;
98 p->print = print;
99 p->visit = visit;
100 Enable_Interrupts;
101 return Num_Types-1;
102 }
103
Init_Type()104 void Init_Type() {
105 int i, bytes;
106 char *p;
107
108 Num_Types = (sizeof(builtin_types) - 1) / sizeof(char *);
109 Max_Type = Num_Types + TYPE_GROW;
110 bytes = Max_Type * sizeof(TYPEDESCR);
111 Types = (TYPEDESCR *)Safe_Malloc(bytes);
112 memset(Types, 0, bytes);
113 for (i = 0; (p = builtin_types[i]); i++) {
114 Types[i].haspointer = *p != '0';
115 Types[i].name = p + 1; /* Skip first character */
116 }
117 }
118