|
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...") */
|
|
20
|
38 xxDEFUN ("ml-defun", ml_defun, 0, UNEVALLED, 0 /*
|
|
0
|
39 Define mocklisp functions
|
|
|
40 */ )
|
|
20
|
41 (Lisp_Object args)
|
|
0
|
42 {
|
|
|
43 Lisp_Object elt;
|
|
|
44
|
|
|
45 while (!NILP (args))
|
|
|
46 {
|
|
|
47 elt = Fcar (args);
|
|
|
48 Ffset (Fcar (elt), Fcons (Qmocklisp, Fcdr (elt)));
|
|
|
49 args = Fcdr (args);
|
|
|
50 }
|
|
|
51 return Qnil;
|
|
|
52 }
|
|
|
53 #endif /* 0 */
|
|
|
54
|
|
|
55
|
|
20
|
56 DEFUN ("ml-if", Fml_if, 0, UNEVALLED, 0, /*
|
|
0
|
57 Mocklisp version of `if'.
|
|
20
|
58 */
|
|
|
59 (args))
|
|
0
|
60 {
|
|
|
61 /* This function can GC */
|
|
|
62 Lisp_Object val;
|
|
|
63 struct gcpro gcpro1;
|
|
|
64
|
|
|
65 GCPRO1 (args);
|
|
|
66 while (!NILP (args))
|
|
|
67 {
|
|
|
68 val = Feval (Fcar (args));
|
|
|
69 args = Fcdr (args);
|
|
|
70 if (NILP (args)) break;
|
|
|
71 if (XINT (val))
|
|
|
72 {
|
|
|
73 val = Feval (Fcar (args));
|
|
|
74 break;
|
|
|
75 }
|
|
|
76 args = Fcdr (args);
|
|
|
77 }
|
|
|
78 UNGCPRO;
|
|
|
79 return val;
|
|
|
80 }
|
|
|
81
|
|
|
82 #if 0 /* Now converted to regular "while" by hairier conversion code. */
|
|
20
|
83 xxDEFUN ("ml-while", ml_while, 1, UNEVALLED, 0 /*
|
|
0
|
84 while for mocklisp programs
|
|
|
85 */ )
|
|
20
|
86 (Lisp_Object args)
|
|
0
|
87 {
|
|
|
88 Lisp_Object test, body, tem;
|
|
|
89 struct gcpro gcpro1, gcpro2;
|
|
|
90
|
|
|
91 GCPRO2 (test, body);
|
|
|
92
|
|
|
93 test = Fcar (args);
|
|
|
94 body = Fcdr (args);
|
|
|
95 while (tem = Feval (test), XINT (tem))
|
|
|
96 {
|
|
|
97 QUIT;
|
|
|
98 Fprogn (body);
|
|
|
99 }
|
|
|
100
|
|
|
101 UNGCPRO;
|
|
|
102 return Qnil;
|
|
|
103 }
|
|
|
104 #endif /* 0 */
|
|
|
105
|
|
|
106
|
|
|
107 /* This is the main entry point to mocklisp execution.
|
|
|
108 When eval sees a mocklisp function being called, it calls here
|
|
|
109 with the unevaluated argument list */
|
|
|
110
|
|
|
111 Lisp_Object
|
|
|
112 ml_apply (Lisp_Object function, Lisp_Object args)
|
|
|
113 {
|
|
|
114 /* This function can GC */
|
|
|
115 int speccount = specpdl_depth ();
|
|
|
116 Lisp_Object val;
|
|
|
117
|
|
|
118 specbind (Qmocklisp_arguments, args);
|
|
|
119 val = Fprogn (Fcdr (function));
|
|
|
120 return unbind_to (speccount, val);
|
|
|
121 }
|
|
|
122
|
|
|
123 #if 0 /* now in lisp code */
|
|
|
124
|
|
|
125 xxDEFUN ("ml-nargs", Fml_nargs, Sml_nargs, 0, 0, 0 /*
|
|
|
126 Number of arguments to currently executing mocklisp function.
|
|
|
127 */ )
|
|
|
128 ()
|
|
|
129 {
|
|
|
130 if (EQ (Vmocklisp_arguments, Qinteractive))
|
|
|
131 return make_int (0);
|
|
|
132 return Flength (Vmocklisp_arguments);
|
|
|
133 }
|
|
|
134
|
|
|
135
|
|
|
136 /* now in lisp code */
|
|
|
137 xxDEFUN ("ml-arg", Fml_arg, Sml_arg, 1, 2, 0 /*
|
|
|
138 Argument number N to currently executing mocklisp function.
|
|
|
139 */ )
|
|
|
140 (n, prompt)
|
|
|
141 Lisp_Object n, prompt;
|
|
|
142 {
|
|
|
143 if (EQ (Vmocklisp_arguments, Qinteractive))
|
|
|
144 return call1 (Qread_from_minibuffer, prompt);
|
|
|
145 CHECK_INT (n);
|
|
|
146 XSETINT (n, XINT (n) - 1); /* Mocklisp likes to be origin-1 */
|
|
|
147 return Fcar (Fnthcdr (n, Vmocklisp_arguments));
|
|
|
148 }
|
|
|
149
|
|
|
150 /* now in lisp code */
|
|
|
151 xxDEFUN ("ml-interactive", Fml_interactive, Sml_interactive, 0, 0, 0 /*
|
|
|
152 True if currently executing mocklisp function was called interactively.
|
|
|
153 */ )
|
|
|
154 ()
|
|
|
155 {
|
|
|
156 return (EQ (Vmocklisp_arguments, Qinteractive)) ? Qt : Qnil;
|
|
|
157 }
|
|
|
158
|
|
|
159 #endif /* 0 */
|
|
|
160
|
|
|
161
|
|
|
162 /* ??? Isn't this the same as `provide-prefix-arg' from mlsupport.el? */
|
|
20
|
163 DEFUN ("ml-provide-prefix-argument", Fml_provide_prefix_argument, 2, UNEVALLED, 0, /*
|
|
0
|
164 Evaluate second argument, using first argument as prefix arg value.
|
|
20
|
165 */
|
|
|
166 (args))
|
|
0
|
167 {
|
|
|
168 /* This function can GC */
|
|
|
169 struct gcpro gcpro1;
|
|
|
170 GCPRO1 (args);
|
|
|
171 Vcurrent_prefix_arg = Feval (Fcar (args));
|
|
|
172 UNGCPRO;
|
|
|
173 return Feval (Fcar (Fcdr (args)));
|
|
|
174 }
|
|
|
175
|
|
20
|
176 DEFUN ("ml-prefix-argument-loop", Fml_prefix_argument_loop, 0, UNEVALLED, 0, /*
|
|
0
|
177
|
|
20
|
178 */
|
|
|
179 (args))
|
|
0
|
180 {
|
|
|
181 /* This function can GC */
|
|
|
182 Lisp_Object tem;
|
|
|
183 int i;
|
|
|
184 struct gcpro gcpro1;
|
|
|
185
|
|
|
186 /* Set `arg' in case we call a built-in function that looks at it. Still are a few. */
|
|
|
187 if (NILP (Vcurrent_prefix_arg))
|
|
|
188 i = 1;
|
|
|
189 else
|
|
|
190 {
|
|
|
191 tem = Vcurrent_prefix_arg;
|
|
|
192 if (CONSP (tem))
|
|
|
193 tem = Fcar (tem);
|
|
|
194 if (EQ (tem, Qminus))
|
|
|
195 i = -1;
|
|
|
196 else i = XINT (tem);
|
|
|
197 }
|
|
|
198
|
|
|
199 GCPRO1 (args);
|
|
|
200 while (i-- > 0)
|
|
|
201 Fprogn (args);
|
|
|
202 UNGCPRO;
|
|
|
203 return Qnil;
|
|
|
204 }
|
|
|
205
|
|
|
206
|
|
|
207 #if 0
|
|
|
208 /* now in lisp code */
|
|
20
|
209 DEFUN ("ml-substr", Fml_substr, 3, 3, 0, /*
|
|
0
|
210 Return a substring of STRING, starting at index FROM and of length LENGTH.
|
|
|
211 If either FROM or LENGTH is negative, the length of STRING is added to it.
|
|
20
|
212 */
|
|
|
213 (string, from, to))
|
|
0
|
214 {
|
|
|
215 CHECK_STRING (string);
|
|
|
216 CHECK_INT (from);
|
|
|
217 CHECK_INT (to);
|
|
|
218
|
|
|
219 if (XINT (from) < 0)
|
|
|
220 XSETINT (from, XINT (from) + string_char_length (XSTRING (string)));
|
|
|
221 if (XINT (to) < 0)
|
|
|
222 XSETINT (to, XINT (to) + string_char_length (XSTRING (string)));
|
|
|
223 XSETINT (to, XINT (to) + XINT (from));
|
|
|
224 return Fsubstring (string, from, to);
|
|
|
225 }
|
|
|
226
|
|
|
227
|
|
|
228 /* now in lisp code */
|
|
20
|
229 DEFUN ("insert-string", Finsert_string, 0, MANY, 0, /*
|
|
0
|
230 Mocklisp-compatibility insert function.
|
|
|
231 Like the function `insert' except that any argument that is a number
|
|
|
232 is converted into a string by expressing it in decimal.
|
|
20
|
233 */
|
|
|
234 (int nargs, Lisp_Object *args))
|
|
0
|
235 {
|
|
|
236 int argnum;
|
|
|
237 Lisp_Object tem;
|
|
|
238
|
|
|
239 for (argnum = 0; argnum < nargs; argnum++)
|
|
|
240 {
|
|
|
241 tem = args[argnum];
|
|
|
242 retry:
|
|
|
243 if (INTP (tem))
|
|
|
244 tem = Fnumber_to_string (tem);
|
|
|
245 if (STRINGP (tem))
|
|
|
246 buffer_insert1 (current_buffer, tem);
|
|
|
247 else
|
|
|
248 {
|
|
|
249 tem = wrong_type_argument (Qstringp, tem);
|
|
|
250 goto retry;
|
|
|
251 }
|
|
|
252 }
|
|
|
253 return Qnil;
|
|
|
254 }
|
|
|
255
|
|
|
256 #endif /* 0 */
|
|
|
257
|
|
|
258
|
|
|
259 /************************************************************************/
|
|
|
260 /* initialization */
|
|
|
261 /************************************************************************/
|
|
|
262
|
|
|
263 void
|
|
|
264 syms_of_mocklisp (void)
|
|
|
265 {
|
|
|
266 defsymbol (&Qmocklisp, "mocklisp");
|
|
|
267 defsymbol (&Qmocklisp_arguments, "mocklisp-arguments");
|
|
|
268
|
|
20
|
269 /*DEFSUBR (Fml_defun);*/
|
|
|
270 DEFSUBR (Fml_if);
|
|
|
271 /*DEFSUBR (Fml_while);*/
|
|
|
272 /*DEFSUBR (Fml_nargs);*/
|
|
|
273 /*DEFSUBR (Fml_arg);*/
|
|
|
274 /*DEFSUBR (Fml_interactive);*/
|
|
|
275 DEFSUBR (Fml_provide_prefix_argument);
|
|
|
276 DEFSUBR (Fml_prefix_argument_loop);
|
|
|
277 /*DEFSUBR (Fml_substr);*/
|
|
|
278 /*DEFSUBR (Finsert_string);*/
|
|
0
|
279 }
|
|
|
280
|
|
|
281 void
|
|
|
282 vars_of_mocklisp (void)
|
|
|
283 {
|
|
|
284 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments /*
|
|
|
285 While in a mocklisp function, the list of its unevaluated args.
|
|
|
286 */ );
|
|
|
287 Vmocklisp_arguments = Qt;
|
|
|
288 }
|
|
|
289
|
|
|
290 #endif /* MOCKLISP_SUPPORT */
|
