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