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 DEFUN ("ml-if", Fml_if, Sml_if, 0, UNEVALLED, 0,
  29        doc: /* Mocklisp version of `if'.
  30 usage: (ml-if COND THEN ELSE...)  */)
  31      (args)
  32      Lisp_Object args;
  33 {
  34   register Lisp_Object val;
  35   struct gcpro gcpro1;
  36
  37   val = Qnil;
  38   GCPRO1 (args);
  39   while (!NILP (args))
  40     {
  41       val = Feval (Fcar (args));
  42       args = Fcdr (args);
  43       if (NILP (args)) break;
  44       if (XINT (val))
  45         {
  46           val = Feval (Fcar (args));
  47           break;
  48         }
  49       args = Fcdr (args);
  50     }
  51   UNGCPRO;
  52   return val;
  53 }
  54
  55 \f
  56 /* This is the main entry point to mocklisp execution.
  57    When eval sees a mocklisp function being called, it calls here
  58    with the unevaluated argument list.  */
  59
  60 Lisp_Object
  61 ml_apply (function, args)
  62      Lisp_Object function, args;
  63 {
  64   register int count = specpdl_ptr - specpdl;
  65   register Lisp_Object val;
  66
  67   specbind (Qmocklisp_arguments, args);
  68   val = Fprogn (Fcdr (function));
  69   return unbind_to (count, val);
  70 }
  71
  72 DEFUN ("ml-nargs", Fml_nargs, Sml_nargs, 0, 0, 0,
  73        doc: /* Number of arguments to currently executing mocklisp function.  */)
  74      ()
  75 {
  76   if (EQ (Vmocklisp_arguments, Qinteractive))
  77     return make_number (0);
  78   return Flength (Vmocklisp_arguments);
  79 }
  80
  81 DEFUN ("ml-arg", Fml_arg, Sml_arg, 1, 2, 0,
  82        doc: /* Argument number N to currently executing mocklisp function.  */)
  83      (n, prompt)
  84      Lisp_Object n, prompt;
  85 {
  86   if (EQ (Vmocklisp_arguments, Qinteractive))
  87     return Fread_string (prompt, Qnil, Qnil, Qnil, Qnil);
  88   CHECK_NUMBER (n);
  89   XSETINT (n, XINT (n) - 1);    /* Mocklisp likes to be origin-1 */
  90   return Fcar (Fnthcdr (n, Vmocklisp_arguments));
  91 }
  92
  93 DEFUN ("ml-interactive", Fml_interactive, Sml_interactive, 0, 0, 0,
  94        doc: /* True if currently executing mocklisp function was called interactively.  */)
  95      ()
  96 {
  97   return (EQ (Vmocklisp_arguments, Qinteractive)) ? Qt : Qnil;
  98 }
  99 \f
 100 DEFUN ("ml-provide-prefix-argument", Fml_provide_prefix_argument, Sml_provide_prefix_argument,
 101        2, UNEVALLED, 0,
 102        doc: /* Evaluate second argument, using first argument as prefix arg value.
 103 usage: (ml-provide-prefix-argument ARG1 ARG2)  */)
 104      (args)
 105      Lisp_Object args;
 106 {
 107   struct gcpro gcpro1;
 108   GCPRO1 (args);
 109   Vcurrent_prefix_arg = Feval (Fcar (args));
 110   UNGCPRO;
 111   return Feval (Fcar (Fcdr (args)));
 112 }
 113
 114 DEFUN ("ml-prefix-argument-loop", Fml_prefix_argument_loop, Sml_prefix_argument_loop,
 115        0, UNEVALLED, 0,
 116        doc: /* usage: (ml-prefix-argument-loop ...)  */)
 117      (args)
 118      Lisp_Object args;
 119 {
 120   register Lisp_Object tem;
 121   register int i;
 122   struct gcpro gcpro1;
 123
 124   /* Set `arg' in case we call a built-in function that looks at it.  Still are a few. */
 125   if (NILP (Vcurrent_prefix_arg))
 126     i = 1;
 127   else
 128     {
 129       tem = Vcurrent_prefix_arg;
 130       if (CONSP (tem))
 131         tem = Fcar (tem);
 132       if (EQ (tem, Qminus))
 133         i = -1;
 134       else i = XINT (tem);
 135     }
 136
 137   GCPRO1 (args);
 138   while (i-- > 0)
 139     Fprogn (args);
 140   UNGCPRO;
 141   return Qnil;
 142 }
 143 \f
 144 DEFUN ("insert-string", Finsert_string, Sinsert_string, 0, MANY, 0,
 145        doc: /* Mocklisp-compatibility insert function.
 146 Like the function `insert' except that any argument that is a number
 147 is converted into a string by expressing it in decimal.
 148 usage: (insert-string &rest ARGS)  */)
 149      (nargs, args)
 150      int nargs;
 151      Lisp_Object *args;
 152 {
 153   register int argnum;
 154   register Lisp_Object tem;
 155
 156   for (argnum = 0; argnum < nargs; argnum++)
 157     {
 158       tem = args[argnum];
 159     retry:
 160       if (INTEGERP (tem))
 161         tem = Fnumber_to_string (tem);
 162       if (STRINGP (tem))
 163         insert1 (tem);
 164       else
 165         {
 166           tem = wrong_type_argument (Qstringp, tem);
 167           goto retry;
 168         }
 169     }
 170
 171   return Qnil;
 172 }
 173
 174 \f
 175 void
 176 syms_of_mocklisp ()
 177 {
 178   Qmocklisp = intern ("mocklisp");
 179   staticpro (&Qmocklisp);
 180
 181   defsubr (&Sml_if);
 182   defsubr (&Sml_arg);
 183   defsubr (&Sml_nargs);
 184   defsubr (&Sml_interactive);
 185   defsubr (&Sml_provide_prefix_argument);
 186   defsubr (&Sml_prefix_argument_loop);
 187   defsubr (&Sinsert_string);
 188 }