home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / e20313sr.zip / emacs / 20.3.1 / src / mocklisp.c < prev    next >
C/C++ Source or Header  |  1999-07-31  |  6KB  |  248 lines
  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.  
  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.  
  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.  
  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.  
  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.  
  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. }
  248.