diff options
Diffstat (limited to 'src/bytecode.c')
-rw-r--r-- | src/bytecode.c | 734 |
1 files changed, 734 insertions, 0 deletions
diff --git a/src/bytecode.c b/src/bytecode.c new file mode 100644 index 00000000000..1a7cd7d73ca --- /dev/null +++ b/src/bytecode.c @@ -0,0 +1,734 @@ +/* Execution of byte code produced by bytecomp.el. + Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 1, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ + + +#include "config.h" +#include "lisp.h" +#include "buffer.h" + +Lisp_Object Qbytecode; + +/* Byte codes: */ + +#define Bvarref 010 +#define Bvarset 020 +#define Bvarbind 030 +#define Bcall 040 +#define Bunbind 050 + +#define Bnth 070 +#define Bsymbolp 071 +#define Bconsp 072 +#define Bstringp 073 +#define Blistp 074 +#define Beq 075 +#define Bmemq 076 +#define Bnot 077 +#define Bcar 0100 +#define Bcdr 0101 +#define Bcons 0102 +#define Blist1 0103 +#define Blist2 0104 +#define Blist3 0105 +#define Blist4 0106 +#define Blength 0107 +#define Baref 0110 +#define Baset 0111 +#define Bsymbol_value 0112 +#define Bsymbol_function 0113 +#define Bset 0114 +#define Bfset 0115 +#define Bget 0116 +#define Bsubstring 0117 +#define Bconcat2 0120 +#define Bconcat3 0121 +#define Bconcat4 0122 +#define Bsub1 0123 +#define Badd1 0124 +#define Beqlsign 0125 +#define Bgtr 0126 +#define Blss 0127 +#define Bleq 0130 +#define Bgeq 0131 +#define Bdiff 0132 +#define Bnegate 0133 +#define Bplus 0134 +#define Bmax 0135 +#define Bmin 0136 + +#define Bpoint 0140 +#define Bmark 0141 /* no longer generated as of v18 */ +#define Bgoto_char 0142 +#define Binsert 0143 +#define Bpoint_max 0144 +#define Bpoint_min 0145 +#define Bchar_after 0146 +#define Bfollowing_char 0147 +#define Bpreceding_char 0150 +#define Bcurrent_column 0151 +#define Bindent_to 0152 +#define Bscan_buffer 0153 /* No longer generated as of v18 */ +#define Beolp 0154 +#define Beobp 0155 +#define Bbolp 0156 +#define Bbobp 0157 +#define Bcurrent_buffer 0160 +#define Bset_buffer 0161 +#define Bread_char 0162 +#define Bset_mark 0163 /* this loser is no longer generated as of v18 */ +#define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */ + +#define Bconstant2 0201 +#define Bgoto 0202 +#define Bgotoifnil 0203 +#define Bgotoifnonnil 0204 +#define Bgotoifnilelsepop 0205 +#define Bgotoifnonnilelsepop 0206 +#define Breturn 0207 +#define Bdiscard 0210 +#define Bdup 0211 + +#define Bsave_excursion 0212 +#define Bsave_window_excursion 0213 +#define Bsave_restriction 0214 +#define Bcatch 0215 + +#define Bunwind_protect 0216 +#define Bcondition_case 0217 +#define Btemp_output_buffer_setup 0220 +#define Btemp_output_buffer_show 0221 + +#define Bconstant 0300 +#define CONSTANTLIM 0100 + +/* Fetch the next byte from the bytecode stream */ + +#define FETCH ((unsigned char *)XSTRING (bytestr)->data)[pc++] + +/* Fetch two bytes from the bytecode stream + and make a 16-bit number out of them */ + +#define FETCH2 (op = FETCH, op + (FETCH << 8)) + +/* Push x onto the execution stack. */ + +#define PUSH(x) (*++stackp = (x)) + +/* Pop a value off the execution stack. */ + +#define POP (*stackp--) + +/* Discard n values from the execution stack. */ + +#define DISCARD(n) (stackp -= (n)) + +/* Get the value which is at the top of the execution stack, but don't pop it. */ + +#define TOP (*stackp) + + +DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0, + "") + (bytestr, vector, maxdepth) + Lisp_Object bytestr, vector, maxdepth; +{ + struct gcpro gcpro1, gcpro2, gcpro3; + int count = specpdl_ptr - specpdl; + register int pc = 0; + register int op; + Lisp_Object *stack; + register Lisp_Object *stackp; + Lisp_Object *stacke; + register Lisp_Object v1, v2; + register Lisp_Object *vectorp = XVECTOR (vector)->contents; + + CHECK_STRING (bytestr, 0); + if (XTYPE (vector) != Lisp_Vector) + vector = wrong_type_argument (Qvectorp, vector); + CHECK_NUMBER (maxdepth, 2); + + stackp = (Lisp_Object *) alloca (XFASTINT (maxdepth) * sizeof (Lisp_Object)); + bzero (stackp, XFASTINT (maxdepth) * sizeof (Lisp_Object)); + GCPRO3 (bytestr, vector, *stackp); + gcpro3.nvars = XFASTINT (maxdepth); + + --stackp; + stack = stackp; + stacke = stackp + XFASTINT (maxdepth); + + while (1) + { + if (stackp > stacke) + error ("Stack overflow in byte code (byte compiler bug), pc = %d", pc); + if (stackp < stack) + error ("Stack underflow in byte code (byte compiler bug), pc = %d", pc); + switch (op = FETCH) + { + case Bvarref+6: + op = FETCH; + goto varref; + + case Bvarref+7: + op = FETCH2; + goto varref; + + case Bvarref: case Bvarref+1: case Bvarref+2: case Bvarref+3: + case Bvarref+4: case Bvarref+5: + op = op - Bvarref; + varref: + v1 = vectorp[op]; + if (XTYPE (v1) != Lisp_Symbol) + v2 = Fsymbol_value (v1); + else + { + v2 = XSYMBOL (v1)->value; +#ifdef SWITCH_ENUM_BUG + switch ((int) XTYPE (v2)) +#else + switch (XTYPE (v2)) +#endif + { + case Lisp_Symbol: + if (!EQ (v2, Qunbound)) + break; + case Lisp_Intfwd: + case Lisp_Boolfwd: + case Lisp_Objfwd: + case Lisp_Buffer_Local_Value: + case Lisp_Some_Buffer_Local_Value: + case Lisp_Buffer_Objfwd: + case Lisp_Void: + v2 = Fsymbol_value (v1); + } + } + PUSH (v2); + break; + + case Bvarset+6: + op = FETCH; + goto varset; + + case Bvarset+7: + op = FETCH2; + goto varset; + + case Bvarset: case Bvarset+1: case Bvarset+2: case Bvarset+3: + case Bvarset+4: case Bvarset+5: + op -= Bvarset; + varset: + Fset (vectorp[op], POP); + break; + + case Bvarbind+6: + op = FETCH; + goto varbind; + + case Bvarbind+7: + op = FETCH2; + goto varbind; + + case Bvarbind: case Bvarbind+1: case Bvarbind+2: case Bvarbind+3: + case Bvarbind+4: case Bvarbind+5: + op -= Bvarbind; + varbind: + specbind (vectorp[op], POP); + break; + + case Bcall+6: + op = FETCH; + goto docall; + + case Bcall+7: + op = FETCH2; + goto docall; + + case Bcall: case Bcall+1: case Bcall+2: case Bcall+3: + case Bcall+4: case Bcall+5: + op -= Bcall; + docall: + DISCARD(op); + /* Ffuncall now follows the standard convention that a + function with MANY args relies on the caller to protect. */ +#if 0 + /* Remove protection from the args we are giving to Ffuncall. + FFuncall will protect them, and double protection would + cause disasters. */ + gcpro3.nvars = &TOP - stack - 1; +#endif + TOP = Ffuncall (op + 1, &TOP); +#if 0 + gcpro3.nvars = XFASTINT (maxdepth); +#endif + break; + + case Bunbind+6: + op = FETCH; + goto dounbind; + + case Bunbind+7: + op = FETCH2; + goto dounbind; + + case Bunbind: case Bunbind+1: case Bunbind+2: case Bunbind+3: + case Bunbind+4: case Bunbind+5: + op -= Bunbind; + dounbind: + unbind_to (specpdl_ptr - specpdl - op); + break; + + case Bgoto: + QUIT; + op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */ + /* A loop always uses a plain goto to jump back. + So this makes sure we consider GC in each loop. */ + if (op < pc && consing_since_gc > gc_cons_threshold) + Fgarbage_collect (); + pc = op; + break; + + case Bgotoifnil: + QUIT; + op = FETCH2; + if (NULL (POP)) + pc = op; + break; + + case Bgotoifnonnil: + QUIT; + op = FETCH2; + if (!NULL (POP)) + pc = op; + break; + + case Bgotoifnilelsepop: + QUIT; + op = FETCH2; + if (NULL (TOP)) + pc = op; + else DISCARD(1); + break; + + case Bgotoifnonnilelsepop: + QUIT; + op = FETCH2; + if (!NULL (TOP)) + pc = op; + else DISCARD(1); + break; + + case Breturn: + v1 = POP; + goto exit; + + case Bdiscard: + DISCARD(1); + break; + + case Bdup: + v1 = TOP; + PUSH (v1); + break; + + case Bconstant2: + PUSH (vectorp[FETCH2]); + break; + + case Bsave_excursion: + record_unwind_protect (save_excursion_restore, save_excursion_save ()); + break; + + case Bsave_window_excursion: + TOP = Fsave_window_excursion (TOP); + break; + + case Bsave_restriction: + record_unwind_protect (save_restriction_restore, save_restriction_save ()); + break; + + case Bcatch: + v1 = POP; + TOP = internal_catch (TOP, Feval, v1); + break; + + case Bunwind_protect: + record_unwind_protect (0, POP); + (specpdl_ptr - 1)->symbol = Qnil; + break; + + case Bcondition_case: + v1 = POP; + v1 = Fcons (POP, v1); + TOP = Fcondition_case (Fcons (TOP, v1)); + break; + + case Btemp_output_buffer_setup: + temp_output_buffer_setup (XSTRING (TOP)->data); + TOP = Vstandard_output; + break; + + case Btemp_output_buffer_show: + v1 = POP; + temp_output_buffer_show (TOP); + TOP = v1; + /* pop binding of standard-output */ + unbind_to (specpdl_ptr - specpdl - 1); + break; + + case Bnth: + v1 = POP; + v2 = TOP; + CHECK_NUMBER (v2, 0); + op = XINT (v2); + immediate_quit = 1; + while (--op >= 0) + { + if (CONSP (v1)) + v1 = XCONS (v1)->cdr; + else if (!NULL (v1)) + { + immediate_quit = 0; + v1 = wrong_type_argument (Qlistp, v1); + immediate_quit = 1; + op++; + } + } + immediate_quit = 0; + goto docar; + + case Bsymbolp: + TOP = XTYPE (TOP) == Lisp_Symbol ? Qt : Qnil; + break; + + case Bconsp: + TOP = CONSP (TOP) ? Qt : Qnil; + break; + + case Bstringp: + TOP = XTYPE (TOP) == Lisp_String ? Qt : Qnil; + break; + + case Blistp: + TOP = CONSP (TOP) || NULL (TOP) ? Qt : Qnil; + break; + + case Beq: + v1 = POP; + TOP = EQ (v1, TOP) ? Qt : Qnil; + break; + + case Bmemq: + v1 = POP; + TOP = Fmemq (TOP, v1); + break; + + case Bnot: + TOP = NULL (TOP) ? Qt : Qnil; + break; + + case Bcar: + v1 = TOP; + docar: + if (CONSP (v1)) TOP = XCONS (v1)->car; + else if (NULL (v1)) TOP = Qnil; + else Fcar (wrong_type_argument (Qlistp, v1)); + break; + + case Bcdr: + v1 = TOP; + if (CONSP (v1)) TOP = XCONS (v1)->cdr; + else if (NULL (v1)) TOP = Qnil; + else Fcdr (wrong_type_argument (Qlistp, v1)); + break; + + case Bcons: + v1 = POP; + TOP = Fcons (TOP, v1); + break; + + case Blist1: + TOP = Fcons (TOP, Qnil); + break; + + case Blist2: + v1 = POP; + TOP = Fcons (TOP, Fcons (v1, Qnil)); + break; + + case Blist3: + DISCARD(2); + TOP = Flist (3, &TOP); + break; + + case Blist4: + DISCARD(3); + TOP = Flist (4, &TOP); + break; + + case Blength: + TOP = Flength (TOP); + break; + + case Baref: + v1 = POP; + TOP = Faref (TOP, v1); + break; + + case Baset: + v2 = POP; v1 = POP; + TOP = Faset (TOP, v1, v2); + break; + + case Bsymbol_value: + TOP = Fsymbol_value (TOP); + break; + + case Bsymbol_function: + TOP = Fsymbol_function (TOP); + break; + + case Bset: + v1 = POP; + TOP = Fset (TOP, v1); + break; + + case Bfset: + v1 = POP; + TOP = Ffset (TOP, v1); + break; + + case Bget: + v1 = POP; + TOP = Fget (TOP, v1); + break; + + case Bsubstring: + v2 = POP; v1 = POP; + TOP = Fsubstring (TOP, v1, v2); + break; + + case Bconcat2: + DISCARD(1); + TOP = Fconcat (2, &TOP); + break; + + case Bconcat3: + DISCARD(2); + TOP = Fconcat (3, &TOP); + break; + + case Bconcat4: + DISCARD(3); + TOP = Fconcat (4, &TOP); + break; + + case Bsub1: + v1 = TOP; + if (XTYPE (v1) == Lisp_Int) + { + XSETINT (v1, XINT (v1) - 1); + TOP = v1; + } + else + TOP = Fsub1 (v1); + break; + + case Badd1: + v1 = TOP; + if (XTYPE (v1) == Lisp_Int) + { + XSETINT (v1, XINT (v1) + 1); + TOP = v1; + } + else + TOP = Fadd1 (v1); + break; + + case Beqlsign: + v2 = POP; v1 = TOP; + CHECK_NUMBER_COERCE_MARKER (v1, 0); + CHECK_NUMBER_COERCE_MARKER (v2, 0); + TOP = XINT (v1) == XINT (v2) ? Qt : Qnil; + break; + + case Bgtr: + v1 = POP; + TOP = Fgtr (TOP, v1); + break; + + case Blss: + v1 = POP; + TOP = Flss (TOP, v1); + break; + + case Bleq: + v1 = POP; + TOP = Fleq (TOP, v1); + break; + + case Bgeq: + v1 = POP; + TOP = Fgeq (TOP, v1); + break; + + case Bdiff: + DISCARD(1); + TOP = Fminus (2, &TOP); + break; + + case Bnegate: + v1 = TOP; + if (XTYPE (v1) == Lisp_Int) + { + XSETINT (v1, - XINT (v1)); + TOP = v1; + } + else + TOP = Fminus (1, &TOP); + break; + + case Bplus: + DISCARD(1); + TOP = Fplus (2, &TOP); + break; + + case Bmax: + DISCARD(1); + TOP = Fmax (2, &TOP); + break; + + case Bmin: + DISCARD(1); + TOP = Fmin (2, &TOP); + break; + + case Bpoint: + XFASTINT (v1) = point; + PUSH (v1); + break; + + case Bmark: /* this loser is no longer generated as of v18 */ + PUSH (Fmarker_position (current_buffer->mark)); + break; + + case Bgoto_char: + TOP = Fgoto_char (TOP); + break; + + case Binsert: + TOP = Finsert (1, &TOP); + break; + + case Bpoint_max: + XFASTINT (v1) = ZV; + PUSH (v1); + break; + + case Bpoint_min: + XFASTINT (v1) = BEGV; + PUSH (v1); + break; + + case Bchar_after: + TOP = Fchar_after (TOP); + break; + + case Bfollowing_char: + XFASTINT (v1) = PT == ZV ? 0 : FETCH_CHAR (point); + PUSH (v1); + break; + + case Bpreceding_char: + XFASTINT (v1) = point == BEGV ? 0 : FETCH_CHAR (point - 1); + PUSH (v1); + break; + + case Bcurrent_column: + XFASTINT (v1) = current_column (); + PUSH (v1); + break; + + case Bindent_to: + TOP = Findent_to (TOP, Qnil); + break; + + case Bscan_buffer: + /* Get an appropriate error. */ + Fsymbol_function (intern ("scan-buffer")); + break; + + case Beolp: + PUSH (Feolp ()); + break; + + case Beobp: + PUSH (Feobp ()); + break; + + case Bbolp: + PUSH (Fbolp ()); + break; + + case Bbobp: + PUSH (Fbobp ()); + break; + + case Bcurrent_buffer: + PUSH (Fcurrent_buffer ()); + break; + + case Bset_buffer: + TOP = Fset_buffer (TOP); + break; + + case Bread_char: + PUSH (Fread_char ()); + QUIT; + break; + + case Bset_mark: /* this loser is no longer generated as of v18 */ + /* TOP = Fset_mark (TOP); */ + TOP = Fset_marker (current_buffer->mark, TOP, Fcurrent_buffer ()); + break; + + case Binteractive_p: + PUSH (Finteractive_p ()); + break; + + default: + if ((op -= Bconstant) < (unsigned)CONSTANTLIM) + PUSH (vectorp[op]); + } + } + + exit: + UNGCPRO; + /* Binds and unbinds are supposed to be compiled balanced. */ + if (specpdl_ptr - specpdl != count) + abort (); + return v1; +} + +syms_of_bytecode () +{ + Qbytecode = intern ("byte-code"); + staticpro (&Qbytecode); + + defsubr (&Sbyte_code); +} + |