|
0
|
1 /* Mocklisp compatibility functions for XEmacs Lisp interpreter.
|
|
|
2 Copyright (C) 1985, 1986, 1992, 1993, 1995 Free Software Foundation, Inc.
|
|
|
3
|
|
|
4 This file is part of XEmacs.
|
|
|
5
|
|
|
6 XEmacs is free software; you can redistribute it and/or modify it
|
|
|
7 under the terms of the GNU General Public License as published by the
|
|
|
8 Free Software Foundation; either version 2, or (at your option) any
|
|
|
9 later version.
|
|
|
10
|
|
|
11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
|
|
|
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
|
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
|
|
14 for more details.
|
|
|
15
|
|
|
16 You should have received a copy of the GNU General Public License
|
|
|
17 along with XEmacs; see the file COPYING. If not, write to
|
|
|
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
19 Boston, MA 02111-1307, USA. */
|
|
|
20
|
|
|
21 /* Synched up with: FSF 19.30. */
|
|
|
22
|
|
|
23
|
|
|
24 /* Compatibility for mocklisp */
|
|
|
25
|
|
|
26 #include <config.h>
|
|
|
27
|
|
|
28 #ifdef MOCKLISP_SUPPORT /* whole file */
|
|
|
29
|
|
|
30 #include "lisp.h"
|
|
|
31 #include "buffer.h"
|
|
|
32
|
|
|
33 Lisp_Object Qmocklisp;
|
|
|
34 Lisp_Object Qmocklisp_arguments;
|
|
|
35 Lisp_Object Vmocklisp_arguments;
|
|
|
36
|
|
|
37 #if 0 /* Now in lisp code ("macrocode...") */
|
|
|
38 xxDEFUN ("ml-defun", Fml_defun, Sml_defun, 0, UNEVALLED, 0 /*
|
|
|
39 Define mocklisp functions
|
|
|
40 */ )
|
|
|
41 (args)
|
|
|
42 Lisp_Object args;
|
|
|
43 {
|
|
|
44 Lisp_Object elt;
|
|
|
45
|
|
|
46 while (!NILP (args))
|
|
|
47 {
|
|
|
48 elt = Fcar (args);
|
|
|
49 Ffset (Fcar (elt), Fcons (Qmocklisp, Fcdr (elt)));
|
|
|
50 args = Fcdr (args);
|
|
|
51 }
|
|
|
52 return Qnil;
|
|
|
53 }
|
|
|
54 #endif /* 0 */
|
|
|
55
|
|
|
56
|
|
|
57 DEFUN ("ml-if", Fml_if, Sml_if, 0, UNEVALLED, 0 /*
|
|
|
58 Mocklisp version of `if'.
|
|
|
59 */ )
|
|
|
60 (args)
|
|
|
61 Lisp_Object args;
|
|
|
62 {
|
|
|
63 /* This function can GC */
|
|
|
64 Lisp_Object val;
|
|
|
65 struct gcpro gcpro1;
|
|
|
66
|
|
|
67 GCPRO1 (args);
|
|
|
68 while (!NILP (args))
|
|
|
69 {
|
|
|
70 val = Feval (Fcar (args));
|
|
|
71 args = Fcdr (args);
|
|
|
72 if (NILP (args)) break;
|
|
|
73 if (XINT (val))
|
|
|
74 {
|
|
|
75 val = Feval (Fcar (args));
|
|
|
76 break;
|
|
|
77 }
|
|
|
78 args = Fcdr (args);
|
|
|
79 }
|
|
|
80 UNGCPRO;
|
|
|
81 return val;
|
|
|
82 }
|
|
|
83
|
|
|
84 #if 0 /* Now converted to regular "while" by hairier conversion code. */
|
|
|
85 xxDEFUN ("ml-while", Fml_while, Sml_while, 1, UNEVALLED, 0 /*
|
|
|
86 while for mocklisp programs
|
|
|
87 */ )
|
|
|
88 (args)
|
|
|
89 Lisp_Object args;
|
|
|
90 {
|
|
|
91 Lisp_Object test, body, tem;
|
|
|
92 struct gcpro gcpro1, gcpro2;
|
|
|
93
|
|
|
94 GCPRO2 (test, body);
|
|
|
95
|
|
|
96 test = Fcar (args);
|
|
|
97 body = Fcdr (args);
|
|
|
98 while (tem = Feval (test), XINT (tem))
|
|
|
99 {
|
|
|
100 QUIT;
|
|
|
101 Fprogn (body);
|
|
|
102 }
|
|
|
103
|
|
|
104 UNGCPRO;
|
|
|
105 return Qnil;
|
|
|
106 }
|
|
|
107 #endif /* 0 */
|
|
|
108
|
|
|
109
|
|
|
110 /* This is the main entry point to mocklisp execution.
|
|
|
111 When eval sees a mocklisp function being called, it calls here
|
|
|
112 with the unevaluated argument list */
|
|
|
113
|
|
|
114 Lisp_Object
|
|
|
115 ml_apply (Lisp_Object function, Lisp_Object args)
|
|
|
116 {
|
|
|
117 /* This function can GC */
|
|
|
118 int speccount = specpdl_depth ();
|
|
|
119 Lisp_Object val;
|
|
|
120
|
|
|
121 specbind (Qmocklisp_arguments, args);
|
|
|
122 val = Fprogn (Fcdr (function));
|
|
|
123 return unbind_to (speccount, val);
|
|
|
124 }
|
|
|
125
|
|
|
126 #if 0 /* now in lisp code */
|
|
|
127
|
|
|
128 xxDEFUN ("ml-nargs", Fml_nargs, Sml_nargs, 0, 0, 0 /*
|
|
|
129 Number of arguments to currently executing mocklisp function.
|
|
|
130 */ )
|
|
|
131 ()
|
|
|
132 {
|
|
|
133 if (EQ (Vmocklisp_arguments, Qinteractive))
|
|
|
134 return make_int (0);
|
|
|
135 return Flength (Vmocklisp_arguments);
|
|
|
136 }
|
|
|
137
|
|
|
138
|
|
|
139 /* now in lisp code */
|
|
|
140 xxDEFUN ("ml-arg", Fml_arg, Sml_arg, 1, 2, 0 /*
|
|
|
141 Argument number N to currently executing mocklisp function.
|
|
|
142 */ )
|
|
|
143 (n, prompt)
|
|
|
144 Lisp_Object n, prompt;
|
|
|
145 {
|
|
|
146 if (EQ (Vmocklisp_arguments, Qinteractive))
|
|
|
147 return call1 (Qread_from_minibuffer, prompt);
|
|
|
148 CHECK_INT (n);
|
|
|
149 XSETINT (n, XINT (n) - 1); /* Mocklisp likes to be origin-1 */
|
|
|
150 return Fcar (Fnthcdr (n, Vmocklisp_arguments));
|
|
|
151 }
|
|
|
152
|
|
|
153 /* now in lisp code */
|
|
|
154 xxDEFUN ("ml-interactive", Fml_interactive, Sml_interactive, 0, 0, 0 /*
|
|
|
155 True if currently executing mocklisp function was called interactively.
|
|
|
156 */ )
|
|
|
157 ()
|
|
|
158 {
|
|
|
159 return (EQ (Vmocklisp_arguments, Qinteractive)) ? Qt : Qnil;
|
|
|
160 }
|
|
|
161
|
|
|
162 #endif /* 0 */
|
|
|
163
|
|
|
164
|
|
|
165 /* ??? Isn't this the same as `provide-prefix-arg' from mlsupport.el? */
|
|
|
166 DEFUN ("ml-provide-prefix-argument", Fml_provide_prefix_argument, Sml_provide_prefix_argument,
|
|
|
167 2, UNEVALLED, 0 /*
|
|
|
168 Evaluate second argument, using first argument as prefix arg value.
|
|
|
169 */ )
|
|
|
170 (args)
|
|
|
171 Lisp_Object args;
|
|
|
172 {
|
|
|
173 /* This function can GC */
|
|
|
174 struct gcpro gcpro1;
|
|
|
175 GCPRO1 (args);
|
|
|
176 Vcurrent_prefix_arg = Feval (Fcar (args));
|
|
|
177 UNGCPRO;
|
|
|
178 return Feval (Fcar (Fcdr (args)));
|
|
|
179 }
|
|
|
180
|
|
|
181 DEFUN ("ml-prefix-argument-loop", Fml_prefix_argument_loop,
|
|
|
182 Sml_prefix_argument_loop,
|
|
|
183 0, UNEVALLED, 0 /*
|
|
|
184
|
|
|
185 */ )
|
|
|
186 (args)
|
|
|
187 Lisp_Object args;
|
|
|
188 {
|
|
|
189 /* This function can GC */
|
|
|
190 Lisp_Object tem;
|
|
|
191 int i;
|
|
|
192 struct gcpro gcpro1;
|
|
|
193
|
|
|
194 /* Set `arg' in case we call a built-in function that looks at it. Still are a few. */
|
|
|
195 if (NILP (Vcurrent_prefix_arg))
|
|
|
196 i = 1;
|
|
|
197 else
|
|
|
198 {
|
|
|
199 tem = Vcurrent_prefix_arg;
|
|
|
200 if (CONSP (tem))
|
|
|
201 tem = Fcar (tem);
|
|
|
202 if (EQ (tem, Qminus))
|
|
|
203 i = -1;
|
|
|
204 else i = XINT (tem);
|
|
|
205 }
|
|
|
206
|
|
|
207 GCPRO1 (args);
|
|
|
208 while (i-- > 0)
|
|
|
209 Fprogn (args);
|
|
|
210 UNGCPRO;
|
|
|
211 return Qnil;
|
|
|
212 }
|
|
|
213
|
|
|
214
|
|
|
215 #if 0
|
|
|
216 /* now in lisp code */
|
|
|
217 DEFUN ("ml-substr", Fml_substr, Sml_substr, 3, 3, 0 /*
|
|
|
218 Return a substring of STRING, starting at index FROM and of length LENGTH.
|
|
|
219 If either FROM or LENGTH is negative, the length of STRING is added to it.
|
|
|
220 */ )
|
|
|
221 (string, from, to)
|
|
|
222 Lisp_Object string, from, to;
|
|
|
223 {
|
|
|
224 CHECK_STRING (string);
|
|
|
225 CHECK_INT (from);
|
|
|
226 CHECK_INT (to);
|
|
|
227
|
|
|
228 if (XINT (from) < 0)
|
|
|
229 XSETINT (from, XINT (from) + string_char_length (XSTRING (string)));
|
|
|
230 if (XINT (to) < 0)
|
|
|
231 XSETINT (to, XINT (to) + string_char_length (XSTRING (string)));
|
|
|
232 XSETINT (to, XINT (to) + XINT (from));
|
|
|
233 return Fsubstring (string, from, to);
|
|
|
234 }
|
|
|
235
|
|
|
236
|
|
|
237 /* now in lisp code */
|
|
|
238 DEFUN ("insert-string", Finsert_string, Sinsert_string, 0, MANY, 0 /*
|
|
|
239 Mocklisp-compatibility insert function.
|
|
|
240 Like the function `insert' except that any argument that is a number
|
|
|
241 is converted into a string by expressing it in decimal.
|
|
|
242 */ )
|
|
|
243 (nargs, args)
|
|
|
244 int nargs;
|
|
|
245 Lisp_Object *args;
|
|
|
246 {
|
|
|
247 int argnum;
|
|
|
248 Lisp_Object tem;
|
|
|
249
|
|
|
250 for (argnum = 0; argnum < nargs; argnum++)
|
|
|
251 {
|
|
|
252 tem = args[argnum];
|
|
|
253 retry:
|
|
|
254 if (INTP (tem))
|
|
|
255 tem = Fnumber_to_string (tem);
|
|
|
256 if (STRINGP (tem))
|
|
|
257 buffer_insert1 (current_buffer, tem);
|
|
|
258 else
|
|
|
259 {
|
|
|
260 tem = wrong_type_argument (Qstringp, tem);
|
|
|
261 goto retry;
|
|
|
262 }
|
|
|
263 }
|
|
|
264 return Qnil;
|
|
|
265 }
|
|
|
266
|
|
|
267 #endif /* 0 */
|
|
|
268
|
|
|
269
|
|
|
270 /************************************************************************/
|
|
|
271 /* initialization */
|
|
|
272 /************************************************************************/
|
|
|
273
|
|
|
274 void
|
|
|
275 syms_of_mocklisp (void)
|
|
|
276 {
|
|
|
277 defsymbol (&Qmocklisp, "mocklisp");
|
|
|
278 defsymbol (&Qmocklisp_arguments, "mocklisp-arguments");
|
|
|
279
|
|
|
280 /*defsubr (&Sml_defun);*/
|
|
|
281 defsubr (&Sml_if);
|
|
|
282 /*defsubr (&Sml_while);*/
|
|
|
283 /*defsubr (&Sml_nargs);*/
|
|
|
284 /*defsubr (&Sml_arg);*/
|
|
|
285 /*defsubr (&Sml_interactive);*/
|
|
|
286 defsubr (&Sml_provide_prefix_argument);
|
|
|
287 defsubr (&Sml_prefix_argument_loop);
|
|
|
288 /*defsubr (&Sml_substr);*/
|
|
|
289 /*defsubr (&Sinsert_string);*/
|
|
|
290 }
|
|
|
291
|
|
|
292 void
|
|
|
293 vars_of_mocklisp (void)
|
|
|
294 {
|
|
|
295 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments /*
|
|
|
296 While in a mocklisp function, the list of its unevaluated args.
|
|
|
297 */ );
|
|
|
298 Vmocklisp_arguments = Qt;
|
|
|
299 }
|
|
|
300
|
|
|
301 #endif /* MOCKLISP_SUPPORT */
|
