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 }