Mercurial > hg > xemacs-beta

comparison src/mocklisp.c @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 859a2309aef8
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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 */