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