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/trace.h>
37
38 status
initialiseProgramObject(Any obj)39 initialiseProgramObject(Any obj)
40 { ProgramObject o = obj;
41
42 o->dflags = (uintptr_t) ZERO | D_SYSTEM;
43
44 succeed;
45 }
46
47
48 status
initialiseNewSlotProgramObject(ProgramObject obj,Variable var)49 initialiseNewSlotProgramObject(ProgramObject obj, Variable var)
50 { if ( var->name == NAME_dflags )
51 obj->dflags = (uintptr_t) ZERO;
52
53 succeed;
54 }
55
56
57 #ifndef O_RUNTIME
58 static unsigned long
nameToTraceFlag(Name name)59 nameToTraceFlag(Name name)
60 { if ( name == NAME_enter )
61 return D_TRACE_ENTER;
62 else if ( name == NAME_exit )
63 return D_TRACE_EXIT;
64 else if ( name == NAME_fail )
65 return D_TRACE_FAIL;
66 else /*if ( name == NAME_full || isDefault(what) )*/
67 return D_TRACE;
68 }
69
70
71 static unsigned long
nameToBreakFlag(Name name)72 nameToBreakFlag(Name name)
73 { if ( name == NAME_enter )
74 return D_BREAK_ENTER;
75 else if ( name == NAME_exit )
76 return D_BREAK_EXIT;
77 else if ( name == NAME_fail )
78 return D_BREAK_FAIL;
79 else /*if ( name == NAME_full || isDefault(what) )*/
80 return D_BREAK;
81 }
82
83
84 static status
traceProgramObject(ProgramObject obj,Name what,BoolObj val)85 traceProgramObject(ProgramObject obj, Name what, BoolObj val)
86 { unsigned long flag = nameToTraceFlag(what);
87
88 if ( val != OFF )
89 { setDFlag(obj, flag);
90 debuggingPce(PCE, ON);
91 } else
92 clearDFlag(obj, flag);
93
94 succeed;
95 }
96
97
98 static BoolObj
getTraceProgramObject(ProgramObject obj,Name what)99 getTraceProgramObject(ProgramObject obj, Name what)
100 { unsigned long flag = nameToTraceFlag(what);
101
102 answer(onDFlag(obj, flag) ? ON : OFF);
103 }
104
105
106 static status
breakProgramObject(ProgramObject obj,Name what,BoolObj val)107 breakProgramObject(ProgramObject obj, Name what, BoolObj val)
108 { unsigned long flag = nameToBreakFlag(what);
109
110 if ( val != OFF )
111 { setDFlag(obj, flag);
112 debuggingPce(PCE, ON);
113 } else
114 clearDFlag(obj, flag);
115
116 succeed;
117 }
118
119
120 static BoolObj
getBreakProgramObject(ProgramObject obj,Name what)121 getBreakProgramObject(ProgramObject obj, Name what)
122 { unsigned long flag = nameToBreakFlag(what);
123
124 answer(onDFlag(obj, flag) ? ON : OFF);
125 }
126
127 #endif /*O_RUNTIME*/
128
129 static status
systemProgramObject(ProgramObject obj,BoolObj val)130 systemProgramObject(ProgramObject obj, BoolObj val)
131 { if ( val == ON )
132 setDFlag(obj, D_SYSTEM);
133 else
134 clearDFlag(obj, D_SYSTEM);
135
136 succeed;
137 }
138
139
140 static BoolObj
getSystemProgramObject(ProgramObject obj)141 getSystemProgramObject(ProgramObject obj)
142 { answer(onDFlag(obj, D_SYSTEM) ? ON : OFF);
143 }
144
145
146 #ifndef TAGGED_LVALUE
147 void
setDFlagProgramObject(Any obj,unsigned long mask)148 setDFlagProgramObject(Any obj, unsigned long mask)
149 { ProgramObject po = obj;
150
151 po->dflags |= mask;
152 }
153
154
155 void
clearDFlagProgramObject(Any obj,unsigned long mask)156 clearDFlagProgramObject(Any obj, unsigned long mask)
157 { ProgramObject po = obj;
158
159 po->dflags &= ~mask;
160 }
161
162 #endif /*TAGGED_LVALUE*/
163
164 /*******************************
165 * CLASS DECLARATION *
166 *******************************/
167
168 /* Type declaractions */
169
170 #ifndef O_RUNTIME
171 static char *T_debug[] =
172 { "ports=[{full,enter,exit,fail}]", "value=[bool]" };
173 #endif
174
175 /* Instance Variables */
176
177 static vardecl var_programObject[] =
178 { IV(NAME_dflags, "int", IV_BOTH,
179 NAME_debugging, "Debugging-flags of the program_object")
180 };
181
182 /* Send Methods */
183
184 static senddecl send_programObject[] =
185 { SM(NAME_initialise, 0, NULL, initialiseProgramObject,
186 DEFAULT, "Create program_object"),
187 SM(NAME_initialiseNewSlot, 1, "variable", initialiseNewSlotProgramObject,
188 NAME_compatibility, "Initialise <-dflags"),
189 #ifndef O_RUNTIME
190 SM(NAME_break, 2, T_debug, breakProgramObject,
191 NAME_debugging, "set/clear break-point on object"),
192 SM(NAME_trace, 2, T_debug, traceProgramObject,
193 NAME_debugging, "set/clear trace-point on object"),
194 #endif /*O_RUNTIME*/
195 SM(NAME_system, 1, "bool", systemProgramObject,
196 NAME_meta, "System defined object?")
197 };
198
199 /* Get Methods */
200
201 static getdecl get_programObject[] =
202 {
203 #ifndef O_RUNTIME
204 GM(NAME_break, 1, "bool", "port=[{enter,exit,fail}]", getBreakProgramObject,
205 NAME_debugging, "Current setting of break-point"),
206 GM(NAME_trace, 1, "bool", "port=[{enter,exit,fail}]", getTraceProgramObject,
207 NAME_debugging, "Current setting of trace-point"),
208 #endif /*O_RUNTIME*/
209 GM(NAME_system, 0, "bool", NULL, getSystemProgramObject,
210 NAME_meta, "System defined object?")
211 };
212
213 /* Resources */
214
215 #define rc_programObject NULL
216 /*
217 static classvardecl rc_programObject[] =
218 {
219 };
220 */
221
222 /* Class Declaration */
223
224 ClassDecl(programObject_decls,
225 var_programObject, send_programObject,
226 get_programObject, rc_programObject,
227 0, NULL,
228 "$Rev$");
229
230
231 status
makeClassProgramObject(Class class)232 makeClassProgramObject(Class class)
233 { declareClass(class, &programObject_decls);
234
235 succeed;
236 }
237
238