code.delx.au - gnu-emacs/blob - 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 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   if (!current_perdisplay)
 144     abort ();
 145   current_perdisplay->Vcurrent_prefix_arg = Feval (Fcar (args));
 146   UNGCPRO;
 147   return Feval (Fcar (Fcdr (args)));
 148 }
 149
 150 DEFUN ("ml-prefix-argument-loop", Fml_prefix_argument_loop, Sml_prefix_argument_loop,
 151        0, UNEVALLED, 0,
 152   "")
 153   (args)
 154      Lisp_Object args;
 155 {
 156   register Lisp_Object tem;
 157   register int i;
 158   struct gcpro gcpro1;
 159
 160   /* Set `arg' in case we call a built-in function that looks at it.  Still are a few. */
 161   if (!current_perdisplay)
 162     abort ();
 163   tem = current_perdisplay->Vcurrent_prefix_arg;
 164   if (NILP (tem))
 165     i = 1;
 166   else
 167     {
 168       if (CONSP (tem))
 169         tem = Fcar (tem);
 170       if (EQ (tem, Qminus))
 171         i = -1;
 172       else i = XINT (tem);
 173     }
 174
 175   GCPRO1 (args);
 176   while (i-- > 0)
 177     Fprogn (args);
 178   UNGCPRO;
 179   return Qnil;
 180 }
 181 \f
 182 #if 0 /* Now in mlsupport.el */
 183
 184 DEFUN ("ml-substr", Fml_substr, Sml_substr, 3, 3, 0,
 185   "Return a substring of STRING, starting at index FROM and of length LENGTH.\n\
 186 If either FROM or LENGTH is negative, the length of STRING is added to it.")
 187   (string, from, to)
 188      Lisp_Object string, from, to;
 189 {
 190   CHECK_STRING (string, 0);
 191   CHECK_NUMBER (from, 1);
 192   CHECK_NUMBER (to, 2);
 193
 194   if (XINT (from) < 0)
 195     XSETINT (from, XINT (from) + XSTRING (string)->size);
 196   if (XINT (to) < 0)
 197     XSETINT (to, XINT (to) + XSTRING (string)->size);
 198   XSETINT (to, XINT (to) + XINT (from));
 199   return Fsubstring (string, from, to);
 200 }
 201 #endif /* 0 */
 202 DEFUN ("insert-string", Finsert_string, Sinsert_string, 0, MANY, 0,
 203   "Mocklisp-compatibility insert function.\n\
 204 Like the function `insert' except that any argument that is a number\n\
 205 is converted into a string by expressing it in decimal.")
 206   (nargs, args)
 207      int nargs;
 208      Lisp_Object *args;
 209 {
 210   register int argnum;
 211   register Lisp_Object tem;
 212
 213   for (argnum = 0; argnum < nargs; argnum++)
 214     {
 215       tem = args[argnum];
 216     retry:
 217       if (INTEGERP (tem))
 218         tem = Fnumber_to_string (tem);
 219       if (STRINGP (tem))
 220         insert1 (tem);
 221       else
 222         {
 223           tem = wrong_type_argument (Qstringp, tem);
 224           goto retry;
 225         }
 226     }
 227
 228   return Qnil;
 229 }
 230
 231 \f
 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 }