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