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