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