Commit | Line | Data |
---|---|---|
14d55bce | 1 | /* Mocklisp compatibility functions for GNU Emacs Lisp interpreter. |
e17cb81b | 2 | Copyright (C) 1985, 1986, 1995 Free Software Foundation, Inc. |
14d55bce RS |
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 | |
7c938215 | 8 | the Free Software Foundation; either version 2, or (at your option) |
14d55bce RS |
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 | |
3b7ad313 EN |
18 | the Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
19 | Boston, MA 02111-1307, USA. */ | |
14d55bce RS |
20 | |
21 | ||
22 | /* Compatibility for mocklisp */ | |
23 | ||
18160b98 | 24 | #include <config.h> |
14d55bce RS |
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 | * | |
d427b66a | 36 | * while (!NILP (args)) |
14d55bce RS |
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 | ||
00df1bdf | 53 | val = Qnil; |
14d55bce | 54 | GCPRO1 (args); |
d427b66a | 55 | while (!NILP (args)) |
14d55bce RS |
56 | { |
57 | val = Feval (Fcar (args)); | |
58 | args = Fcdr (args); | |
d427b66a | 59 | if (NILP (args)) break; |
14d55bce RS |
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 | ||
23ce2486 KH |
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 | |
14d55bce RS |
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)) | |
1e206719 | 125 | return Fread_string (prompt, Qnil, Qnil, Qnil, Qnil); |
14d55bce RS |
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); | |
4a7bcf34 | 146 | Vcurrent_prefix_arg = Feval (Fcar (args)); |
14d55bce RS |
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. */ | |
4a7bcf34 | 162 | if (NILP (Vcurrent_prefix_arg)) |
14d55bce RS |
163 | i = 1; |
164 | else | |
165 | { | |
4a7bcf34 | 166 | tem = Vcurrent_prefix_arg; |
14d55bce RS |
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 | } | |
02665de7 | 200 | #endif /* 0 */ |
14d55bce RS |
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: | |
fb8116a7 | 216 | if (INTEGERP (tem)) |
f2980264 | 217 | tem = Fnumber_to_string (tem); |
fb8116a7 | 218 | if (STRINGP (tem)) |
14d55bce RS |
219 | insert1 (tem); |
220 | else | |
221 | { | |
222 | tem = wrong_type_argument (Qstringp, tem); | |
223 | goto retry; | |
224 | } | |
225 | } | |
36e37d63 | 226 | |
14d55bce RS |
227 | return Qnil; |
228 | } | |
229 | ||
230 | \f | |
dfcf069d | 231 | void |
14d55bce RS |
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 | } |