1 /*
2 * gloc.c - gloc implementation
3 *
4 * Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org>
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
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 FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 */
33
34 #define LIBGAUCHE_BODY
35 #include "gauche.h"
36
37 /*---------------------------------------------------------------
38 * GLOCs
39 */
40
gloc_print(ScmObj obj,ScmPort * port,ScmWriteContext * ctx SCM_UNUSED)41 static void gloc_print(ScmObj obj, ScmPort *port,
42 ScmWriteContext *ctx SCM_UNUSED)
43 {
44 ScmGloc *g = SCM_GLOC(obj);
45 Scm_Printf(port, "#<gloc %S#%S%s>", g->module->name,
46 g->name,
47 (Scm_GlocConstP(g)
48 ? " const"
49 : (Scm_GlocInlinableP(g)
50 ? " inlinable"
51 : (SCM_GLOC_PHANTOM_BINDING_P(g)
52 ? " phantom"
53 : ""))));
54 }
55
56 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_GlocClass, gloc_print);
57
Scm_MakeGloc(ScmSymbol * sym,ScmModule * module)58 ScmObj Scm_MakeGloc(ScmSymbol *sym, ScmModule *module)
59 {
60 ScmGloc *g = SCM_NEW(ScmGloc);
61 SCM_SET_CLASS(g, &Scm_GlocClass);
62 g->name = sym;
63 g->module = module;
64 g->value = SCM_UNBOUND;
65 g->hidden = FALSE;
66 g->getter = NULL;
67 g->setter = NULL;
68 return SCM_OBJ(g);
69 }
70
71 /* special setters for const and inlinable bindings. */
Scm_GlocConstSetter(ScmGloc * gloc,ScmObj val SCM_UNUSED)72 ScmObj Scm_GlocConstSetter(ScmGloc *gloc, ScmObj val SCM_UNUSED)
73 {
74 Scm_Error("cannot change constant value of %S#%S",
75 gloc->module->name, gloc->name);
76 return SCM_UNDEFINED; /* dummy */
77 }
78
Scm_GlocInlinableSetter(ScmGloc * gloc,ScmObj val)79 ScmObj Scm_GlocInlinableSetter(ScmGloc *gloc, ScmObj val)
80 {
81 Scm_Warn("altering binding of inlinable procedure: %S#%S",
82 gloc->module->name, gloc->name);
83 return val;
84 }
85
Scm_GlocConstP(ScmGloc * gloc)86 int Scm_GlocConstP(ScmGloc *gloc)
87 {
88 return ((gloc)->setter == Scm_GlocConstSetter);
89 }
90
Scm_GlocInlinableP(ScmGloc * gloc)91 int Scm_GlocInlinableP(ScmGloc *gloc)
92 {
93 return ((gloc)->setter == Scm_GlocInlinableSetter);
94 }
95
96 /* Change binding flags. Do not use casually. */
Scm_GlocMark(ScmGloc * gloc,int flags)97 void Scm_GlocMark(ScmGloc *gloc, int flags)
98 {
99 if (flags & SCM_BINDING_CONST) {
100 gloc->setter = Scm_GlocConstSetter;
101 } else if (flags & SCM_BINDING_INLINABLE) {
102 gloc->setter = Scm_GlocInlinableSetter;
103 } else {
104 gloc->setter = NULL;
105 }
106 }
107
108 /* For the backward ABI compatibility */
Scm_GlocMarkConst(ScmGloc * gloc)109 ScmObj Scm_GlocMarkConst(ScmGloc *gloc)
110 {
111 Scm_GlocMark(gloc, SCM_BINDING_CONST);
112 return SCM_OBJ(gloc);
113 }
114
115 /* For the backward ABI compatibility */
Scm_GlocUnmarkConst(ScmGloc * gloc)116 ScmObj Scm_GlocUnmarkConst(ScmGloc *gloc)
117 {
118 Scm_GlocMark(gloc, 0);
119 return SCM_OBJ(gloc);
120 }
121
122