4.3BSD - /usr/src/new/emacs/src/mocklisp.c

   1: /* Mocklisp compatibility functions for GNU Emacs Lisp interpreter.
   2:    Copyright (C) 1985 Richard M. Stallman.
   3: 
   4: This file is part of GNU Emacs.
   5: 
   6: GNU Emacs is distributed in the hope that it will be useful,
   7: but WITHOUT ANY WARRANTY.  No author or distributor
   8: accepts responsibility to anyone for the consequences of using it
   9: or for whether it serves any particular purpose or works at all,
  10: unless he says so in writing.  Refer to the GNU Emacs General Public
  11: License for full details.
  12: 
  13: Everyone is granted permission to copy, modify and redistribute
  14: GNU Emacs, but only under the conditions described in the
  15: GNU Emacs General Public License.   A copy of this license is
  16: supposed to have been given to you along with GNU Emacs so you
  17: can know your rights and responsibilities.  It should be in a
  18: file named COPYING.  Among other things, the copyright notice
  19: and this notice must be preserved on all copies.  */
  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 (!NULL (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, "if  for mocklisp programs")
  47:   (args)
  48:      Lisp_Object args;
  49: {
  50:   register Lisp_Object val;
  51:   struct gcpro gcpro1;
  52: 
  53:   GCPRO1 (args);
  54:   while (!NULL (args))
  55:     {
  56:       val = Feval (Fcar (args));
  57:       args = Fcdr (args);
  58:       if (NULL (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: 
  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:   unbind_to (count);
 106:   return val;
 107: }
 108: 
 109: DEFUN ("ml-nargs", Fml_nargs, Sml_nargs, 0, 0, 0, "# arguments to this 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, "Argument #N to this 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 this mocklisp function was called interactively.")
 130:   ()
 131: {
 132:   return (EQ (Vmocklisp_arguments, Qinteractive)) ? Qt : Qnil;
 133: }
 134: 
 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:   Vcurrent_prefix_arg = Feval (Fcar (args));
 144:   UNGCPRO;
 145:   return Feval (Fcar (Fcdr (args)));
 146: }
 147: 
 148: DEFUN ("ml-prefix-argument-loop", Fml_prefix_argument_loop, Sml_prefix_argument_loop,
 149:        0, UNEVALLED, 0,
 150:   "")
 151:   (args)
 152:      Lisp_Object args;
 153: {
 154:   register Lisp_Object tem;
 155:   register int i;
 156:   struct gcpro gcpro1;
 157: 
 158:   /* Set `arg' in case we call a built-in function that looks at it.  Still are a few. */
 159:   if (NULL (Vcurrent_prefix_arg))
 160:     i = 1;
 161:   else
 162:     {
 163:       tem = Vcurrent_prefix_arg;
 164:       if (LISTP (tem))
 165:     tem = Fcar (tem);
 166:       if (EQ (tem, Qminus))
 167:     i = -1;
 168:       else i = XINT (tem);
 169:     }
 170: 
 171:   GCPRO1 (args);
 172:   while (i-- > 0)
 173:     Fprogn (args);
 174:   UNGCPRO;
 175:   return Qnil;
 176: }
 177: 
 178: DEFUN ("ml-substr", Fml_substr, Sml_substr, 3, 3, 0,
 179:   "Return a substring of STRING, starting at index FROM and of length LENGTH.\n\
 180: If either FROM or LENGTH is negative, the length of STRING is added to it.")
 181:   (string, from, to)
 182:      Lisp_Object string, from, to;
 183: {
 184:   CHECK_STRING (string, 0);
 185:   CHECK_NUMBER (from, 1);
 186:   CHECK_NUMBER (to, 2);
 187: 
 188:   if (XINT (from) < 0)
 189:     XSETINT (from, XINT (from) + XSTRING (string)->size);
 190:   if (XINT (to) < 0)
 191:     XSETINT (to, XINT (to) + XSTRING (string)->size);
 192:   XSETINT (to, XINT (to) + XINT (from));
 193:   return Fsubstring (string, from, to);
 194: }
 195: 
 196: DEFUN ("insert-string", Finsert_string, Sinsert_string, 0, MANY, 0,
 197:   "Insert the arguments (all strings) into the buffer, moving point forward.\n\
 198: Any argument that is a number is converted to a string by printing it in decimal.")
 199:   (nargs, args)
 200:      int nargs;
 201:      Lisp_Object *args;
 202: {
 203:   register int argnum;
 204:   register Lisp_Object tem;
 205: 
 206:   for (argnum = 0; argnum < nargs; argnum++)
 207:     {
 208:       tem = args[argnum];
 209:     retry:
 210:       if (XTYPE (tem) == Lisp_Int)
 211:     tem = Fint_to_string (tem);
 212:       if (XTYPE (tem) == Lisp_String)
 213:     {
 214:       InsCStr (XSTRING (tem)->data, XSTRING (tem)->size);
 215:     }
 216:       else
 217:     {
 218:       tem = wrong_type_argument (Qstringp, tem);
 219:       goto retry;
 220:     }
 221:     }
 222:   return Qnil;
 223: }
 224: 
 225: 
 226: syms_of_mocklisp ()
 227: {
 228:   Qmocklisp = intern ("mocklisp");
 229:   staticpro (&Qmocklisp);
 230: 
 231: /*defsubr (&Sml_defun);*/
 232:   defsubr (&Sml_if);
 233: /*defsubr (&Sml_while);*/
 234:   defsubr (&Sml_arg);
 235:   defsubr (&Sml_nargs);
 236:   defsubr (&Sml_interactive);
 237:   defsubr (&Sml_provide_prefix_argument);
 238:   defsubr (&Sml_prefix_argument_loop);
 239:   defsubr (&Sml_substr);
 240:   defsubr (&Sinsert_string);
 241: }

Defined functions