Mercurial > hg > xemacs-beta
annotate src/bytecode.c @ 4792:95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
lisp/ChangeLog addition:
2009-11-08 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (cl-string-vector-equalp)
(cl-bit-vector-vector-equalp, cl-vector-array-equalp)
(cl-hash-table-contents-equalp): New functions, to implement
equalp treating arrays with identical contents as equivalent, as
specified by Common Lisp.
(equalp): Revise this function to implement array equivalence,
and the hash-table equalp behaviour specified by CL.
* cl-macs.el (equalp): Add a compiler macro for this function,
used when one of the arguments is constant, and as such, its type
is known at compile time.
man/ChangeLog addition:
2009-11-08 Aidan Kehoe <kehoea@parhasard.net>
* lispref/objects.texi (Equality Predicates):
Document #'equalp here, as well as #'equal and #'eq.
tests/ChangeLog addition:
2009-12-31 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test much of the functionality of equalp; add a pointer to Paul
Dietz' ANSI test suite for this function, converted to Emacs
Lisp. Not including the tests themselves in XEmacs because who
owns the copyright on the files is unclear and the GCL people
didn't respond to my queries.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 31 Dec 2009 15:09:41 +0000 |
| parents | 1d61580e0cf7 |
| children | 6772ce4d982b 19a72041c5ed e0db3c197671 |
| rev | line source |
|---|---|
| 428 | 1 /* Execution of byte code produced by bytecomp.el. |
| 2 Implementation of compiled-function objects. | |
| 3 Copyright (C) 1992, 1993 Free Software Foundation, Inc. | |
| 814 | 4 Copyright (C) 1995, 2002 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: Mule 2.0, FSF 19.30. */ | |
| 24 | |
| 25 /* This file has been Mule-ized. */ | |
| 26 | |
| 27 | |
| 28 /* Authorship: | |
| 29 | |
| 30 FSF: long ago. | |
| 31 | |
| 32 hacked on by jwz@jwz.org 1991-06 | |
| 33 o added a compile-time switch to turn on simple sanity checking; | |
| 34 o put back the obsolete byte-codes for error-detection; | |
| 35 o added a new instruction, unbind_all, which I will use for | |
| 36 tail-recursion elimination; | |
| 37 o made temp_output_buffer_show be called with the right number | |
| 38 of args; | |
| 39 o made the new bytecodes be called with args in the right order; | |
| 40 o added metering support. | |
| 41 | |
| 42 by Hallvard: | |
| 43 o added relative jump instructions; | |
| 44 o all conditionals now only do QUIT if they jump. | |
| 45 | |
| 46 Ben Wing: some changes for Mule, 1995-06. | |
| 47 | |
| 48 Martin Buchholz: performance hacking, 1998-09. | |
| 49 See Internals Manual, Evaluation. | |
| 50 */ | |
| 51 | |
| 52 #include <config.h> | |
| 53 #include "lisp.h" | |
| 54 #include "backtrace.h" | |
| 55 #include "buffer.h" | |
| 56 #include "bytecode.h" | |
| 57 #include "opaque.h" | |
| 58 #include "syntax.h" | |
| 872 | 59 #include "window.h" |
| 428 | 60 |
| 3092 | 61 #ifdef NEW_GC |
| 62 static Lisp_Object | |
| 63 make_compiled_function_args (int totalargs) | |
| 64 { | |
| 65 Lisp_Compiled_Function_Args *args; | |
| 66 args = (Lisp_Compiled_Function_Args *) | |
| 67 alloc_lrecord | |
| 68 (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args, | |
| 69 Lisp_Object, args, totalargs), | |
| 70 &lrecord_compiled_function_args); | |
| 71 args->size = totalargs; | |
| 72 return wrap_compiled_function_args (args); | |
| 73 } | |
| 74 | |
| 75 static Bytecount | |
| 76 size_compiled_function_args (const void *lheader) | |
| 77 { | |
| 78 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args, | |
| 79 Lisp_Object, args, | |
| 80 ((Lisp_Compiled_Function_Args *) | |
| 81 lheader)->size); | |
| 82 } | |
| 83 | |
| 84 static const struct memory_description compiled_function_args_description[] = { | |
| 85 { XD_LONG, offsetof (Lisp_Compiled_Function_Args, size) }, | |
| 86 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Compiled_Function_Args, args), | |
| 87 XD_INDIRECT(0, 0) }, | |
| 88 { XD_END } | |
| 89 }; | |
| 90 | |
| 91 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("compiled-function-args", | |
| 92 compiled_function_args, | |
| 93 1, /*dumpable-flag*/ | |
| 94 0, 0, 0, 0, 0, | |
| 95 compiled_function_args_description, | |
| 96 size_compiled_function_args, | |
| 97 Lisp_Compiled_Function_Args); | |
| 98 #endif /* NEW_GC */ | |
| 99 | |
| 428 | 100 EXFUN (Ffetch_bytecode, 1); |
| 101 | |
| 102 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code; | |
| 103 | |
| 104 enum Opcode /* Byte codes */ | |
| 105 { | |
| 106 Bvarref = 010, | |
| 107 Bvarset = 020, | |
| 108 Bvarbind = 030, | |
| 109 Bcall = 040, | |
| 110 Bunbind = 050, | |
| 111 | |
| 112 Bnth = 070, | |
| 113 Bsymbolp = 071, | |
| 114 Bconsp = 072, | |
| 115 Bstringp = 073, | |
| 116 Blistp = 074, | |
| 117 Bold_eq = 075, | |
| 118 Bold_memq = 076, | |
| 119 Bnot = 077, | |
| 120 Bcar = 0100, | |
| 121 Bcdr = 0101, | |
| 122 Bcons = 0102, | |
| 123 Blist1 = 0103, | |
| 124 Blist2 = 0104, | |
| 125 Blist3 = 0105, | |
| 126 Blist4 = 0106, | |
| 127 Blength = 0107, | |
| 128 Baref = 0110, | |
| 129 Baset = 0111, | |
| 130 Bsymbol_value = 0112, | |
| 131 Bsymbol_function = 0113, | |
| 132 Bset = 0114, | |
| 133 Bfset = 0115, | |
| 134 Bget = 0116, | |
| 135 Bsubstring = 0117, | |
| 136 Bconcat2 = 0120, | |
| 137 Bconcat3 = 0121, | |
| 138 Bconcat4 = 0122, | |
| 139 Bsub1 = 0123, | |
| 140 Badd1 = 0124, | |
| 141 Beqlsign = 0125, | |
| 142 Bgtr = 0126, | |
| 143 Blss = 0127, | |
| 144 Bleq = 0130, | |
| 145 Bgeq = 0131, | |
| 146 Bdiff = 0132, | |
| 147 Bnegate = 0133, | |
| 148 Bplus = 0134, | |
| 149 Bmax = 0135, | |
| 150 Bmin = 0136, | |
| 151 Bmult = 0137, | |
| 152 | |
| 153 Bpoint = 0140, | |
| 154 Beq = 0141, /* was Bmark, | |
| 155 but no longer generated as of v18 */ | |
| 156 Bgoto_char = 0142, | |
| 157 Binsert = 0143, | |
| 158 Bpoint_max = 0144, | |
| 159 Bpoint_min = 0145, | |
| 160 Bchar_after = 0146, | |
| 161 Bfollowing_char = 0147, | |
| 162 Bpreceding_char = 0150, | |
| 163 Bcurrent_column = 0151, | |
| 164 Bindent_to = 0152, | |
| 165 Bequal = 0153, /* was Bscan_buffer, | |
| 166 but no longer generated as of v18 */ | |
| 167 Beolp = 0154, | |
| 168 Beobp = 0155, | |
| 169 Bbolp = 0156, | |
| 170 Bbobp = 0157, | |
| 171 Bcurrent_buffer = 0160, | |
| 172 Bset_buffer = 0161, | |
| 173 Bsave_current_buffer = 0162, /* was Bread_char, | |
| 174 but no longer generated as of v19 */ | |
| 175 Bmemq = 0163, /* was Bset_mark, | |
| 176 but no longer generated as of v18 */ | |
| 177 Binteractive_p = 0164, /* Needed since interactive-p takes | |
| 178 unevalled args */ | |
| 179 Bforward_char = 0165, | |
| 180 Bforward_word = 0166, | |
| 181 Bskip_chars_forward = 0167, | |
| 182 Bskip_chars_backward = 0170, | |
| 183 Bforward_line = 0171, | |
| 184 Bchar_syntax = 0172, | |
| 185 Bbuffer_substring = 0173, | |
| 186 Bdelete_region = 0174, | |
| 187 Bnarrow_to_region = 0175, | |
| 188 Bwiden = 0176, | |
| 189 Bend_of_line = 0177, | |
| 190 | |
| 191 Bconstant2 = 0201, | |
| 192 Bgoto = 0202, | |
| 193 Bgotoifnil = 0203, | |
| 194 Bgotoifnonnil = 0204, | |
| 195 Bgotoifnilelsepop = 0205, | |
| 196 Bgotoifnonnilelsepop = 0206, | |
| 197 Breturn = 0207, | |
| 198 Bdiscard = 0210, | |
| 199 Bdup = 0211, | |
| 200 | |
| 201 Bsave_excursion = 0212, | |
| 202 Bsave_window_excursion= 0213, | |
| 203 Bsave_restriction = 0214, | |
| 204 Bcatch = 0215, | |
| 205 | |
| 206 Bunwind_protect = 0216, | |
| 207 Bcondition_case = 0217, | |
| 208 Btemp_output_buffer_setup = 0220, | |
| 209 Btemp_output_buffer_show = 0221, | |
| 210 | |
| 211 Bunbind_all = 0222, | |
| 212 | |
| 213 Bset_marker = 0223, | |
| 214 Bmatch_beginning = 0224, | |
| 215 Bmatch_end = 0225, | |
| 216 Bupcase = 0226, | |
| 217 Bdowncase = 0227, | |
| 218 | |
| 219 Bstring_equal = 0230, | |
| 220 Bstring_lessp = 0231, | |
| 221 Bold_equal = 0232, | |
| 222 Bnthcdr = 0233, | |
| 223 Belt = 0234, | |
| 224 Bold_member = 0235, | |
| 225 Bold_assq = 0236, | |
| 226 Bnreverse = 0237, | |
| 227 Bsetcar = 0240, | |
| 228 Bsetcdr = 0241, | |
| 229 Bcar_safe = 0242, | |
| 230 Bcdr_safe = 0243, | |
| 231 Bnconc = 0244, | |
| 232 Bquo = 0245, | |
| 233 Brem = 0246, | |
| 234 Bnumberp = 0247, | |
| 235 Bintegerp = 0250, | |
| 236 | |
| 237 BRgoto = 0252, | |
| 238 BRgotoifnil = 0253, | |
| 239 BRgotoifnonnil = 0254, | |
| 240 BRgotoifnilelsepop = 0255, | |
| 241 BRgotoifnonnilelsepop = 0256, | |
| 242 | |
| 243 BlistN = 0257, | |
| 244 BconcatN = 0260, | |
| 245 BinsertN = 0261, | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
246 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
247 Bbind_multiple_value_limits = 0262, /* New in 21.5. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
248 Bmultiple_value_list_internal = 0263, /* New in 21.5. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
249 Bmultiple_value_call = 0264, /* New in 21.5. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
250 Bthrow = 0265, /* New in 21.5. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
251 |
| 428 | 252 Bmember = 0266, /* new in v20 */ |
| 253 Bassq = 0267, /* new in v20 */ | |
| 254 | |
| 255 Bconstant = 0300 | |
| 256 }; | |
| 257 typedef enum Opcode Opcode; | |
| 258 | |
| 259 | |
| 260 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr, | |
| 442 | 261 const Opbyte *program_ptr, |
| 428 | 262 Opcode opcode); |
| 263 | |
| 264 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram. | |
| 265 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */ | |
| 266 /* #define BYTE_CODE_METER */ | |
| 267 | |
| 268 | |
| 269 #ifdef BYTE_CODE_METER | |
| 270 | |
| 271 Lisp_Object Vbyte_code_meter, Qbyte_code_meter; | |
| 272 int byte_metering_on; | |
| 273 | |
| 274 static void | |
| 275 meter_code (Opcode prev_opcode, Opcode this_opcode) | |
| 276 { | |
| 277 if (byte_metering_on) | |
| 278 { | |
| 279 Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]); | |
| 280 p[0] = INT_PLUS1 (p[0]); | |
| 281 if (prev_opcode) | |
| 282 p[prev_opcode] = INT_PLUS1 (p[prev_opcode]); | |
| 283 } | |
| 284 } | |
| 285 | |
| 286 #endif /* BYTE_CODE_METER */ | |
| 287 | |
| 288 | |
| 289 static Lisp_Object | |
| 290 bytecode_negate (Lisp_Object obj) | |
| 291 { | |
| 292 retry: | |
| 293 | |
| 1983 | 294 if (INTP (obj)) return make_integer (- XINT (obj)); |
| 428 | 295 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj)); |
| 1983 | 296 if (CHARP (obj)) return make_integer (- ((int) XCHAR (obj))); |
| 297 if (MARKERP (obj)) return make_integer (- ((int) marker_position (obj))); | |
| 298 #ifdef HAVE_BIGNUM | |
| 299 if (BIGNUMP (obj)) BIGNUM_ARITH_RETURN (obj, neg); | |
| 300 #endif | |
| 301 #ifdef HAVE_RATIO | |
| 302 if (RATIOP (obj)) RATIO_ARITH_RETURN (obj, neg); | |
| 303 #endif | |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
304 #ifdef HAVE_BIGFLOAT |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4677
diff
changeset
|
305 if (BIGFLOATP (obj)) BIGFLOAT_ARITH_RETURN (obj, neg); |
| 1983 | 306 #endif |
| 428 | 307 |
| 308 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); | |
| 309 goto retry; | |
| 310 } | |
| 311 | |
| 312 static Lisp_Object | |
| 313 bytecode_nreverse (Lisp_Object list) | |
| 314 { | |
| 315 REGISTER Lisp_Object prev = Qnil; | |
| 316 REGISTER Lisp_Object tail = list; | |
| 317 | |
| 318 while (!NILP (tail)) | |
| 319 { | |
| 320 REGISTER Lisp_Object next; | |
| 321 CHECK_CONS (tail); | |
| 322 next = XCDR (tail); | |
| 323 XCDR (tail) = prev; | |
| 324 prev = tail; | |
| 325 tail = next; | |
| 326 } | |
| 327 return prev; | |
| 328 } | |
| 329 | |
| 330 | |
| 331 /* We have our own two-argument versions of various arithmetic ops. | |
| 332 Only two-argument arithmetic operations have their own byte codes. */ | |
| 333 static int | |
| 334 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2) | |
| 335 { | |
| 1983 | 336 #ifdef WITH_NUMBER_TYPES |
| 337 switch (promote_args (&obj1, &obj2)) | |
| 338 { | |
| 339 case FIXNUM_T: | |
| 340 { | |
| 341 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2); | |
| 342 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0; | |
| 343 } | |
| 344 #ifdef HAVE_BIGNUM | |
| 345 case BIGNUM_T: | |
| 346 return bignum_cmp (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); | |
| 347 #endif | |
| 348 #ifdef HAVE_RATIO | |
| 349 case RATIO_T: | |
| 350 return ratio_cmp (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 351 #endif | |
| 1995 | 352 #ifdef HAVE_BIGFLOAT |
| 353 case BIGFLOAT_T: | |
| 354 return bigfloat_cmp (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); | |
| 355 #endif | |
| 356 default: /* FLOAT_T */ | |
| 1983 | 357 { |
| 358 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2); | |
| 359 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; | |
| 360 } | |
| 361 } | |
| 362 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 363 retry: |
| 364 | |
| 365 { | |
| 366 EMACS_INT ival1, ival2; | |
| 367 | |
| 368 if (INTP (obj1)) ival1 = XINT (obj1); | |
| 369 else if (CHARP (obj1)) ival1 = XCHAR (obj1); | |
| 370 else if (MARKERP (obj1)) ival1 = marker_position (obj1); | |
| 371 else goto arithcompare_float; | |
| 372 | |
| 373 if (INTP (obj2)) ival2 = XINT (obj2); | |
| 374 else if (CHARP (obj2)) ival2 = XCHAR (obj2); | |
| 375 else if (MARKERP (obj2)) ival2 = marker_position (obj2); | |
| 376 else goto arithcompare_float; | |
| 377 | |
| 378 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0; | |
| 379 } | |
| 380 | |
| 381 arithcompare_float: | |
| 382 | |
| 383 { | |
| 384 double dval1, dval2; | |
| 385 | |
| 386 if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1); | |
| 387 else if (INTP (obj1)) dval1 = (double) XINT (obj1); | |
| 388 else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1); | |
| 389 else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1); | |
| 390 else | |
| 391 { | |
| 392 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); | |
| 393 goto retry; | |
| 394 } | |
| 395 | |
| 396 if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2); | |
| 397 else if (INTP (obj2)) dval2 = (double) XINT (obj2); | |
| 398 else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2); | |
| 399 else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2); | |
| 400 else | |
| 401 { | |
| 402 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); | |
| 403 goto retry; | |
| 404 } | |
| 405 | |
| 406 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; | |
| 407 } | |
| 1983 | 408 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 409 } |
| 410 | |
| 411 static Lisp_Object | |
| 412 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode) | |
| 413 { | |
| 1983 | 414 #ifdef WITH_NUMBER_TYPES |
| 415 switch (promote_args (&obj1, &obj2)) | |
| 416 { | |
| 417 case FIXNUM_T: | |
| 418 { | |
| 419 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2); | |
| 420 switch (opcode) | |
| 421 { | |
| 422 case Bplus: ival1 += ival2; break; | |
| 423 case Bdiff: ival1 -= ival2; break; | |
| 424 case Bmult: | |
| 425 #ifdef HAVE_BIGNUM | |
| 426 /* Due to potential overflow, we compute using bignums */ | |
| 427 bignum_set_long (scratch_bignum, ival1); | |
| 428 bignum_set_long (scratch_bignum2, ival2); | |
| 429 bignum_mul (scratch_bignum, scratch_bignum, scratch_bignum2); | |
| 430 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 431 #else | |
| 432 ival1 *= ival2; break; | |
| 433 #endif | |
| 434 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
435 if (ival2 == 0) |
|
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
436 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 437 ival1 /= ival2; |
| 438 break; | |
| 439 case Bmax: if (ival1 < ival2) ival1 = ival2; break; | |
| 440 case Bmin: if (ival1 > ival2) ival1 = ival2; break; | |
| 441 } | |
| 442 return make_integer (ival1); | |
| 443 } | |
| 444 #ifdef HAVE_BIGNUM | |
| 445 case BIGNUM_T: | |
| 446 switch (opcode) | |
| 447 { | |
| 448 case Bplus: | |
| 449 bignum_add (scratch_bignum, XBIGNUM_DATA (obj1), | |
| 450 XBIGNUM_DATA (obj2)); | |
| 451 break; | |
| 452 case Bdiff: | |
| 453 bignum_sub (scratch_bignum, XBIGNUM_DATA (obj1), | |
| 454 XBIGNUM_DATA (obj2)); | |
| 455 break; | |
| 456 case Bmult: | |
| 457 bignum_mul (scratch_bignum, XBIGNUM_DATA (obj1), | |
| 458 XBIGNUM_DATA (obj2)); | |
| 459 break; | |
| 460 case Bquo: | |
| 461 if (bignum_sign (XBIGNUM_DATA (obj2)) == 0) | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
462 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 463 bignum_div (scratch_bignum, XBIGNUM_DATA (obj1), |
| 464 XBIGNUM_DATA (obj2)); | |
| 465 break; | |
| 466 case Bmax: | |
| 467 return bignum_gt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)) | |
| 468 ? obj1 : obj2; | |
| 469 case Bmin: | |
| 470 return bignum_lt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)) | |
| 471 ? obj1 : obj2; | |
| 472 } | |
| 473 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 474 #endif | |
| 475 #ifdef HAVE_RATIO | |
| 476 case RATIO_T: | |
| 477 switch (opcode) | |
| 478 { | |
| 479 case Bplus: | |
| 480 ratio_add (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 481 break; | |
| 482 case Bdiff: | |
| 483 ratio_sub (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 484 break; | |
| 485 case Bmult: | |
| 486 ratio_mul (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
| 487 break; | |
| 488 case Bquo: | |
| 489 if (ratio_sign (XRATIO_DATA (obj2)) == 0) | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
490 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 491 ratio_div (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2)); |
| 492 break; | |
| 493 case Bmax: | |
| 494 return ratio_gt (XRATIO_DATA (obj1), XRATIO_DATA (obj2)) | |
| 495 ? obj1 : obj2; | |
| 496 case Bmin: | |
| 497 return ratio_lt (XRATIO_DATA (obj1), XRATIO_DATA (obj2)) | |
| 498 ? obj1 : obj2; | |
| 499 } | |
| 500 return make_ratio_rt (scratch_ratio); | |
| 501 #endif | |
| 502 #ifdef HAVE_BIGFLOAT | |
| 503 case BIGFLOAT_T: | |
| 504 bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (obj1), | |
| 505 XBIGFLOAT_GET_PREC (obj2))); | |
| 506 switch (opcode) | |
| 507 { | |
| 508 case Bplus: | |
| 509 bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (obj1), | |
| 510 XBIGFLOAT_DATA (obj2)); | |
| 511 break; | |
| 512 case Bdiff: | |
| 513 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (obj1), | |
| 514 XBIGFLOAT_DATA (obj2)); | |
| 515 break; | |
| 516 case Bmult: | |
| 517 bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (obj1), | |
| 518 XBIGFLOAT_DATA (obj2)); | |
| 519 break; | |
| 520 case Bquo: | |
| 521 if (bigfloat_sign (XBIGFLOAT_DATA (obj2)) == 0) | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
522 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1983 | 523 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (obj1), |
| 524 XBIGFLOAT_DATA (obj2)); | |
| 525 break; | |
| 526 case Bmax: | |
| 527 return bigfloat_gt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)) | |
| 528 ? obj1 : obj2; | |
| 529 case Bmin: | |
| 530 return bigfloat_lt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)) | |
| 531 ? obj1 : obj2; | |
| 532 } | |
| 533 return make_bigfloat_bf (scratch_bigfloat); | |
| 534 #endif | |
| 1995 | 535 default: /* FLOAT_T */ |
| 536 { | |
| 537 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2); | |
| 538 switch (opcode) | |
| 539 { | |
| 540 case Bplus: dval1 += dval2; break; | |
| 541 case Bdiff: dval1 -= dval2; break; | |
| 542 case Bmult: dval1 *= dval2; break; | |
| 543 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
544 if (dval2 == 0.0) |
|
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
545 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 1995 | 546 dval1 /= dval2; |
| 547 break; | |
| 548 case Bmax: if (dval1 < dval2) dval1 = dval2; break; | |
| 549 case Bmin: if (dval1 > dval2) dval1 = dval2; break; | |
| 550 } | |
| 551 return make_float (dval1); | |
| 552 } | |
| 1983 | 553 } |
| 554 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 555 EMACS_INT ival1, ival2; |
| 556 int float_p; | |
| 557 | |
| 558 retry: | |
| 559 | |
| 560 float_p = 0; | |
| 561 | |
| 562 if (INTP (obj1)) ival1 = XINT (obj1); | |
| 563 else if (CHARP (obj1)) ival1 = XCHAR (obj1); | |
| 564 else if (MARKERP (obj1)) ival1 = marker_position (obj1); | |
| 565 else if (FLOATP (obj1)) ival1 = 0, float_p = 1; | |
| 566 else | |
| 567 { | |
| 568 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); | |
| 569 goto retry; | |
| 570 } | |
| 571 | |
| 572 if (INTP (obj2)) ival2 = XINT (obj2); | |
| 573 else if (CHARP (obj2)) ival2 = XCHAR (obj2); | |
| 574 else if (MARKERP (obj2)) ival2 = marker_position (obj2); | |
| 575 else if (FLOATP (obj2)) ival2 = 0, float_p = 1; | |
| 576 else | |
| 577 { | |
| 578 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); | |
| 579 goto retry; | |
| 580 } | |
| 581 | |
| 582 if (!float_p) | |
| 583 { | |
| 584 switch (opcode) | |
| 585 { | |
| 586 case Bplus: ival1 += ival2; break; | |
| 587 case Bdiff: ival1 -= ival2; break; | |
| 588 case Bmult: ival1 *= ival2; break; | |
| 589 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
590 if (ival2 == 0) |
|
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
591 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 428 | 592 ival1 /= ival2; |
| 593 break; | |
| 594 case Bmax: if (ival1 < ival2) ival1 = ival2; break; | |
| 595 case Bmin: if (ival1 > ival2) ival1 = ival2; break; | |
| 596 } | |
| 597 return make_int (ival1); | |
| 598 } | |
| 599 else | |
| 600 { | |
| 601 double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1; | |
| 602 double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2; | |
| 603 switch (opcode) | |
| 604 { | |
| 605 case Bplus: dval1 += dval2; break; | |
| 606 case Bdiff: dval1 -= dval2; break; | |
| 607 case Bmult: dval1 *= dval2; break; | |
| 608 case Bquo: | |
|
4717
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
609 if (dval2 == 0) |
|
fcc7e89d5e68
Properly handle continuable divide-by-zero errors. Fix truncation of a
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
610 signal_error_2 (Qarith_error, "division by zero", obj1, obj2); |
| 428 | 611 dval1 /= dval2; |
| 612 break; | |
| 613 case Bmax: if (dval1 < dval2) dval1 = dval2; break; | |
| 614 case Bmin: if (dval1 > dval2) dval1 = dval2; break; | |
| 615 } | |
| 616 return make_float (dval1); | |
| 617 } | |
| 1983 | 618 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 619 } |
| 620 | |
| 621 | |
| 622 /* Read next uint8 from the instruction stream. */ | |
| 623 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++) | |
| 624 | |
| 625 /* Read next uint16 from the instruction stream. */ | |
| 626 #define READ_UINT_2 \ | |
| 627 (program_ptr += 2, \ | |
| 628 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \ | |
| 629 ((unsigned int) (unsigned char) program_ptr[-2]))) | |
| 630 | |
| 631 /* Read next int8 from the instruction stream. */ | |
| 632 #define READ_INT_1 ((int) (signed char) *program_ptr++) | |
| 633 | |
| 634 /* Read next int16 from the instruction stream. */ | |
| 635 #define READ_INT_2 \ | |
| 636 (program_ptr += 2, \ | |
| 637 (((int) ( signed char) program_ptr[-1]) * 256 + \ | |
| 638 ((int) (unsigned char) program_ptr[-2]))) | |
| 639 | |
| 640 /* Read next int8 from instruction stream; don't advance program_pointer */ | |
| 641 #define PEEK_INT_1 ((int) (signed char) program_ptr[0]) | |
| 642 | |
| 643 /* Read next int16 from instruction stream; don't advance program_pointer */ | |
| 644 #define PEEK_INT_2 \ | |
| 645 ((((int) ( signed char) program_ptr[1]) * 256) | \ | |
| 646 ((int) (unsigned char) program_ptr[0])) | |
| 647 | |
| 648 /* Do relative jumps from the current location. | |
| 649 We only do a QUIT if we jump backwards, for efficiency. | |
| 650 No infloops without backward jumps! */ | |
| 651 #define JUMP_RELATIVE(jump) do { \ | |
| 652 int JR_jump = (jump); \ | |
| 653 if (JR_jump < 0) QUIT; \ | |
| 654 program_ptr += JR_jump; \ | |
| 655 } while (0) | |
| 656 | |
| 657 #define JUMP JUMP_RELATIVE (PEEK_INT_2) | |
| 658 #define JUMPR JUMP_RELATIVE (PEEK_INT_1) | |
| 659 | |
| 660 #define JUMP_NEXT ((void) (program_ptr += 2)) | |
| 661 #define JUMPR_NEXT ((void) (program_ptr += 1)) | |
| 662 | |
| 663 /* Push x onto the execution stack. */ | |
| 664 #define PUSH(x) (*++stack_ptr = (x)) | |
| 665 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
666 /* Pop a value, which may be multiple, off the execution stack. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
667 #define POP_WITH_MULTIPLE_VALUES (*stack_ptr--) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
668 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
669 /* Pop a value off the execution stack, treating multiple values as single. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
670 #define POP (IGNORE_MULTIPLE_VALUES (POP_WITH_MULTIPLE_VALUES)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
671 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
672 #define DISCARD_PRESERVING_MULTIPLE_VALUES(n) (stack_ptr -= (n)) |
| 428 | 673 |
| 674 /* Discard n values from the execution stack. */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
675 #define DISCARD(n) do { \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
676 if (1 != multiple_value_current_limit) \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
677 { \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
678 int i, en = n; \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
679 for (i = 0; i < en; i++) \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
680 { \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
681 *stack_ptr = ignore_multiple_values (*stack_ptr); \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
682 stack_ptr--; \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
683 } \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
684 } \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
685 else \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
686 { \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
687 stack_ptr -= (n); \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
688 } \ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
689 } while (0) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
690 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
691 /* Get the value, which may be multiple, at the top of the execution stack; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
692 and leave it there. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
693 #define TOP_WITH_MULTIPLE_VALUES (*stack_ptr) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
694 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
695 #define TOP_ADDRESS (stack_ptr) |
| 428 | 696 |
| 697 /* Get the value which is at the top of the execution stack, | |
| 698 but don't pop it. */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
699 #define TOP (IGNORE_MULTIPLE_VALUES (TOP_WITH_MULTIPLE_VALUES)) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
700 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
701 #define TOP_LVALUE (*stack_ptr) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
702 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
703 |
| 428 | 704 |
| 1920 | 705 /* See comment before the big switch in execute_optimized_program(). */ |
| 1884 | 706 #define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg) |
| 707 | |
| 428 | 708 /* The actual interpreter for byte code. |
| 709 This function has been seriously optimized for performance. | |
| 710 Don't change the constructs unless you are willing to do | |
| 711 real benchmarking and profiling work -- martin */ | |
| 712 | |
| 713 | |
| 814 | 714 Lisp_Object |
| 442 | 715 execute_optimized_program (const Opbyte *program, |
| 428 | 716 int stack_depth, |
| 717 Lisp_Object *constants_data) | |
| 718 { | |
| 719 /* This function can GC */ | |
| 442 | 720 REGISTER const Opbyte *program_ptr = (Opbyte *) program; |
| 1884 | 721 Lisp_Object *stack_beg = alloca_array (Lisp_Object, stack_depth + 1); |
| 722 REGISTER Lisp_Object *stack_ptr = stack_beg; | |
| 428 | 723 int speccount = specpdl_depth (); |
| 724 struct gcpro gcpro1; | |
| 725 | |
| 726 #ifdef BYTE_CODE_METER | |
| 727 Opcode this_opcode = 0; | |
| 728 Opcode prev_opcode; | |
| 729 #endif | |
| 730 | |
| 731 #ifdef ERROR_CHECK_BYTE_CODE | |
| 732 Lisp_Object *stack_end = stack_beg + stack_depth; | |
| 733 #endif | |
| 734 | |
| 1920 | 735 /* We used to GCPRO the whole interpreter stack before entering this while |
| 736 loop (21.5.14 and before), but that interferes with collection of weakly | |
| 737 referenced objects. Although strictly speaking there's no promise that | |
| 738 weak references will disappear by any given point in time, they should | |
| 739 be collected at the first opportunity. Waiting until exit from the | |
| 740 function caused test failures because "stale" objects "above" the top of | |
| 741 the stack were still GCPROed, and they were not getting collected until | |
| 742 after exit from the (byte-compiled) test! | |
| 743 | |
| 744 Now the idea is to dynamically adjust the array of GCPROed objects to | |
| 745 include only the "active" region of the stack. | |
| 746 | |
| 747 We use the "GCPRO1 the array base and set the nvars member" method. It | |
| 748 would be slightly inefficient but correct to use GCPRO1_ARRAY here. It | |
| 749 would just redundantly set nvars. | |
| 750 #### Maybe it would be clearer to use GCPRO1_ARRAY and do GCPRO_STACK | |
| 751 after the switch? | |
| 752 | |
| 753 GCPRO_STACK is something of a misnomer, because it suggests that a | |
| 754 struct gcpro is initialized each time. This is false; only the nvars | |
| 755 member of a single struct gcpro is being adjusted. This works because | |
| 756 each time a new object is assigned to a stack location, the old object | |
| 757 loses its reference and is effectively UNGCPROed, and the new object is | |
| 758 automatically GCPROed as long as nvars is correct. Only when we | |
| 759 return from the interpreter do we need to finalize the struct gcpro | |
| 760 itself, and that's done at case Breturn. | |
| 761 */ | |
| 428 | 762 GCPRO1 (stack_ptr[1]); |
| 1758 | 763 |
| 428 | 764 while (1) |
| 765 { | |
| 766 REGISTER Opcode opcode = (Opcode) READ_UINT_1; | |
| 1920 | 767 |
| 768 GCPRO_STACK; /* Get nvars right before maybe signaling. */ | |
| 428 | 769 #ifdef ERROR_CHECK_BYTE_CODE |
| 770 if (stack_ptr > stack_end) | |
| 563 | 771 stack_overflow ("byte code stack overflow", Qunbound); |
| 428 | 772 if (stack_ptr < stack_beg) |
| 563 | 773 stack_overflow ("byte code stack underflow", Qunbound); |
| 428 | 774 #endif |
| 775 | |
| 776 #ifdef BYTE_CODE_METER | |
| 777 prev_opcode = this_opcode; | |
| 778 this_opcode = opcode; | |
| 779 meter_code (prev_opcode, this_opcode); | |
| 780 #endif | |
| 781 | |
| 782 switch (opcode) | |
| 783 { | |
| 784 REGISTER int n; | |
| 785 | |
| 786 default: | |
| 787 if (opcode >= Bconstant) | |
| 788 PUSH (constants_data[opcode - Bconstant]); | |
| 789 else | |
| 1884 | 790 { |
| 791 /* We're not sure what these do, so better safe than sorry. */ | |
| 792 /* GCPRO_STACK; */ | |
| 793 stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode); | |
| 794 } | |
| 428 | 795 break; |
| 796 | |
| 797 case Bvarref: | |
| 798 case Bvarref+1: | |
| 799 case Bvarref+2: | |
| 800 case Bvarref+3: | |
| 801 case Bvarref+4: | |
| 802 case Bvarref+5: n = opcode - Bvarref; goto do_varref; | |
| 803 case Bvarref+7: n = READ_UINT_2; goto do_varref; | |
| 804 case Bvarref+6: n = READ_UINT_1; /* most common */ | |
| 805 do_varref: | |
| 806 { | |
| 807 Lisp_Object symbol = constants_data[n]; | |
| 808 Lisp_Object value = XSYMBOL (symbol)->value; | |
| 809 if (SYMBOL_VALUE_MAGIC_P (value)) | |
| 1920 | 810 /* I GCPRO_STACKed Fsymbol_value elsewhere, but I dunno why. */ |
| 811 /* GCPRO_STACK; */ | |
| 428 | 812 value = Fsymbol_value (symbol); |
| 813 PUSH (value); | |
| 814 break; | |
| 815 } | |
| 816 | |
| 817 case Bvarset: | |
| 818 case Bvarset+1: | |
| 819 case Bvarset+2: | |
| 820 case Bvarset+3: | |
| 821 case Bvarset+4: | |
| 822 case Bvarset+5: n = opcode - Bvarset; goto do_varset; | |
| 823 case Bvarset+7: n = READ_UINT_2; goto do_varset; | |
| 824 case Bvarset+6: n = READ_UINT_1; /* most common */ | |
| 825 do_varset: | |
| 826 { | |
| 827 Lisp_Object symbol = constants_data[n]; | |
| 440 | 828 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); |
| 428 | 829 Lisp_Object old_value = symbol_ptr->value; |
| 830 Lisp_Object new_value = POP; | |
| 1661 | 831 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) |
| 428 | 832 symbol_ptr->value = new_value; |
| 1884 | 833 else { |
| 834 /* Fset may call magic handlers */ | |
| 835 /* GCPRO_STACK; */ | |
| 428 | 836 Fset (symbol, new_value); |
| 1884 | 837 } |
| 838 | |
| 428 | 839 break; |
| 840 } | |
| 841 | |
| 842 case Bvarbind: | |
| 843 case Bvarbind+1: | |
| 844 case Bvarbind+2: | |
| 845 case Bvarbind+3: | |
| 846 case Bvarbind+4: | |
| 847 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind; | |
| 848 case Bvarbind+7: n = READ_UINT_2; goto do_varbind; | |
| 849 case Bvarbind+6: n = READ_UINT_1; /* most common */ | |
| 850 do_varbind: | |
| 851 { | |
| 852 Lisp_Object symbol = constants_data[n]; | |
| 440 | 853 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); |
| 428 | 854 Lisp_Object old_value = symbol_ptr->value; |
| 855 Lisp_Object new_value = POP; | |
| 856 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) | |
| 857 { | |
| 858 specpdl_ptr->symbol = symbol; | |
| 859 specpdl_ptr->old_value = old_value; | |
| 860 specpdl_ptr->func = 0; | |
| 861 specpdl_ptr++; | |
| 862 specpdl_depth_counter++; | |
| 863 | |
| 864 symbol_ptr->value = new_value; | |
| 853 | 865 |
| 866 #ifdef ERROR_CHECK_CATCH | |
| 867 check_specbind_stack_sanity (); | |
| 868 #endif | |
| 428 | 869 } |
| 870 else | |
| 1884 | 871 { |
| 872 /* does an Fset, may call magic handlers */ | |
| 873 /* GCPRO_STACK; */ | |
| 874 specbind_magic (symbol, new_value); | |
| 875 } | |
| 428 | 876 break; |
| 877 } | |
| 878 | |
| 879 case Bcall: | |
| 880 case Bcall+1: | |
| 881 case Bcall+2: | |
| 882 case Bcall+3: | |
| 883 case Bcall+4: | |
| 884 case Bcall+5: | |
| 885 case Bcall+6: | |
| 886 case Bcall+7: | |
| 887 n = (opcode < Bcall+6 ? opcode - Bcall : | |
| 888 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2); | |
| 1920 | 889 /* #### Shouldn't this be just before the Ffuncall? |
| 890 Neither Fget nor Fput can GC. */ | |
| 1884 | 891 /* GCPRO_STACK; */ |
| 428 | 892 DISCARD (n); |
| 893 #ifdef BYTE_CODE_METER | |
| 894 if (byte_metering_on && SYMBOLP (TOP)) | |
| 895 { | |
| 896 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil); | |
| 897 if (INTP (val)) | |
| 898 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1)); | |
| 899 } | |
| 900 #endif | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
901 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
902 TOP_LVALUE = Ffuncall (n + 1, TOP_ADDRESS); |
| 428 | 903 break; |
| 904 | |
| 905 case Bunbind: | |
| 906 case Bunbind+1: | |
| 907 case Bunbind+2: | |
| 908 case Bunbind+3: | |
| 909 case Bunbind+4: | |
| 910 case Bunbind+5: | |
| 911 case Bunbind+6: | |
| 912 case Bunbind+7: | |
| 913 UNBIND_TO (specpdl_depth() - | |
| 914 (opcode < Bunbind+6 ? opcode-Bunbind : | |
| 915 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2)); | |
| 916 break; | |
| 917 | |
| 918 | |
| 919 case Bgoto: | |
| 920 JUMP; | |
| 921 break; | |
| 922 | |
| 923 case Bgotoifnil: | |
| 924 if (NILP (POP)) | |
| 925 JUMP; | |
| 926 else | |
| 927 JUMP_NEXT; | |
| 928 break; | |
| 929 | |
| 930 case Bgotoifnonnil: | |
| 931 if (!NILP (POP)) | |
| 932 JUMP; | |
| 933 else | |
| 934 JUMP_NEXT; | |
| 935 break; | |
| 936 | |
| 937 case Bgotoifnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
938 /* Discard any multiple value: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
939 if (NILP (TOP_LVALUE = TOP)) |
| 428 | 940 JUMP; |
| 941 else | |
| 942 { | |
| 943 DISCARD (1); | |
| 944 JUMP_NEXT; | |
| 945 } | |
| 946 break; | |
| 947 | |
| 948 case Bgotoifnonnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
949 /* Discard any multiple value: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
950 if (!NILP (TOP_LVALUE = TOP)) |
| 428 | 951 JUMP; |
| 952 else | |
| 953 { | |
| 954 DISCARD (1); | |
| 955 JUMP_NEXT; | |
| 956 } | |
| 957 break; | |
| 958 | |
| 959 | |
| 960 case BRgoto: | |
| 961 JUMPR; | |
| 962 break; | |
| 963 | |
| 964 case BRgotoifnil: | |
| 965 if (NILP (POP)) | |
| 966 JUMPR; | |
| 967 else | |
| 968 JUMPR_NEXT; | |
| 969 break; | |
| 970 | |
| 971 case BRgotoifnonnil: | |
| 972 if (!NILP (POP)) | |
| 973 JUMPR; | |
| 974 else | |
| 975 JUMPR_NEXT; | |
| 976 break; | |
| 977 | |
| 978 case BRgotoifnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
979 if (NILP (TOP_LVALUE = TOP)) |
| 428 | 980 JUMPR; |
| 981 else | |
| 982 { | |
| 983 DISCARD (1); | |
| 984 JUMPR_NEXT; | |
| 985 } | |
| 986 break; | |
| 987 | |
| 988 case BRgotoifnonnilelsepop: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
989 if (!NILP (TOP_LVALUE = TOP)) |
| 428 | 990 JUMPR; |
| 991 else | |
| 992 { | |
| 993 DISCARD (1); | |
| 994 JUMPR_NEXT; | |
| 995 } | |
| 996 break; | |
| 997 | |
| 998 case Breturn: | |
| 999 UNGCPRO; | |
| 1000 #ifdef ERROR_CHECK_BYTE_CODE | |
| 1001 /* Binds and unbinds are supposed to be compiled balanced. */ | |
| 1002 if (specpdl_depth() != speccount) | |
| 563 | 1003 invalid_byte_code ("unbalanced specbinding stack", Qunbound); |
| 428 | 1004 #endif |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1005 return TOP_WITH_MULTIPLE_VALUES; |
| 428 | 1006 |
| 1007 case Bdiscard: | |
| 1008 DISCARD (1); | |
| 1009 break; | |
| 1010 | |
| 1011 case Bdup: | |
| 1012 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1013 Lisp_Object arg = TOP_WITH_MULTIPLE_VALUES; |
| 428 | 1014 PUSH (arg); |
| 1015 break; | |
| 1016 } | |
| 1017 | |
| 1018 case Bconstant2: | |
| 1019 PUSH (constants_data[READ_UINT_2]); | |
| 1020 break; | |
| 1021 | |
| 1022 case Bcar: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1023 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1024 /* Fcar can GC via wrong_type_argument. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1025 /* GCPRO_STACK; */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1026 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1027 TOP_LVALUE = CONSP (arg) ? XCAR (arg) : Fcar (arg); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1028 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1029 } |
| 428 | 1030 |
| 1031 case Bcdr: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1032 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1033 /* Fcdr can GC via wrong_type_argument. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1034 /* GCPRO_STACK; */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1035 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1036 TOP_LVALUE = CONSP (arg) ? XCDR (arg) : Fcdr (arg); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1037 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1038 } |
| 428 | 1039 |
| 1040 case Bunbind_all: | |
| 1041 /* To unbind back to the beginning of this frame. Not used yet, | |
| 1042 but will be needed for tail-recursion elimination. */ | |
| 771 | 1043 unbind_to (speccount); |
| 428 | 1044 break; |
| 1045 | |
| 1046 case Bnth: | |
| 1047 { | |
| 1048 Lisp_Object arg = POP; | |
| 1920 | 1049 /* Fcar and Fnthcdr can GC via wrong_type_argument. */ |
| 1050 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1051 TOP_LVALUE = Fcar (Fnthcdr (TOP, arg)); |
| 428 | 1052 break; |
| 1053 } | |
| 1054 | |
| 1055 case Bsymbolp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1056 TOP_LVALUE = SYMBOLP (TOP) ? Qt : Qnil; |
| 428 | 1057 break; |
| 1058 | |
| 1059 case Bconsp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1060 TOP_LVALUE = CONSP (TOP) ? Qt : Qnil; |
| 428 | 1061 break; |
| 1062 | |
| 1063 case Bstringp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1064 TOP_LVALUE = STRINGP (TOP) ? Qt : Qnil; |
| 428 | 1065 break; |
| 1066 | |
| 1067 case Blistp: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1068 TOP_LVALUE = LISTP (TOP) ? Qt : Qnil; |
| 428 | 1069 break; |
| 1070 | |
| 1071 case Bnumberp: | |
| 1983 | 1072 #ifdef WITH_NUMBER_TYPES |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1073 TOP_LVALUE = NUMBERP (TOP) ? Qt : Qnil; |
| 1983 | 1074 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1075 TOP_LVALUE = INT_OR_FLOATP (TOP) ? Qt : Qnil; |
| 1983 | 1076 #endif |
| 428 | 1077 break; |
| 1078 | |
| 1079 case Bintegerp: | |
| 1983 | 1080 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1081 TOP_LVALUE = INTEGERP (TOP) ? Qt : Qnil; |
| 1983 | 1082 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1083 TOP_LVALUE = INTP (TOP) ? Qt : Qnil; |
| 1983 | 1084 #endif |
| 428 | 1085 break; |
| 1086 | |
| 1087 case Beq: | |
| 1088 { | |
| 1089 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1090 TOP_LVALUE = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil; |
| 428 | 1091 break; |
| 1092 } | |
| 1093 | |
| 1094 case Bnot: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1095 TOP_LVALUE = NILP (TOP) ? Qt : Qnil; |
| 428 | 1096 break; |
| 1097 | |
| 1098 case Bcons: | |
| 1099 { | |
| 1100 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1101 TOP_LVALUE = Fcons (TOP, arg); |
| 428 | 1102 break; |
| 1103 } | |
| 1104 | |
| 1105 case Blist1: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1106 TOP_LVALUE = Fcons (TOP, Qnil); |
| 428 | 1107 break; |
| 1108 | |
| 1109 | |
| 1110 case BlistN: | |
| 1111 n = READ_UINT_1; | |
| 1112 goto do_list; | |
| 1113 | |
| 1114 case Blist2: | |
| 1115 case Blist3: | |
| 1116 case Blist4: | |
| 1117 /* common case */ | |
| 1118 n = opcode - (Blist1 - 1); | |
| 1119 do_list: | |
| 1120 { | |
| 1121 Lisp_Object list = Qnil; | |
| 1122 list_loop: | |
| 1123 list = Fcons (TOP, list); | |
| 1124 if (--n) | |
| 1125 { | |
| 1126 DISCARD (1); | |
| 1127 goto list_loop; | |
| 1128 } | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1129 TOP_LVALUE = list; |
| 428 | 1130 break; |
| 1131 } | |
| 1132 | |
| 1133 | |
| 1134 case Bconcat2: | |
| 1135 case Bconcat3: | |
| 1136 case Bconcat4: | |
| 1137 n = opcode - (Bconcat2 - 2); | |
| 1138 goto do_concat; | |
| 1139 | |
| 1140 case BconcatN: | |
| 1141 /* common case */ | |
| 1142 n = READ_UINT_1; | |
| 1143 do_concat: | |
| 1144 DISCARD (n - 1); | |
| 1920 | 1145 /* Apparently `concat' can GC; Fconcat GCPROs its arguments. */ |
| 1146 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1147 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1148 TOP_LVALUE = Fconcat (n, TOP_ADDRESS); |
| 428 | 1149 break; |
| 1150 | |
| 1151 | |
| 1152 case Blength: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1153 TOP_LVALUE = Flength (TOP); |
| 428 | 1154 break; |
| 1155 | |
| 1156 case Baset: | |
| 1157 { | |
| 1158 Lisp_Object arg2 = POP; | |
| 1159 Lisp_Object arg1 = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1160 TOP_LVALUE = Faset (TOP, arg1, arg2); |
| 428 | 1161 break; |
| 1162 } | |
| 1163 | |
| 1164 case Bsymbol_value: | |
| 1920 | 1165 /* Why does this need GCPRO_STACK? If not, remove others, too. */ |
| 1884 | 1166 /* GCPRO_STACK; */ |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1167 TOP_LVALUE = Fsymbol_value (TOP); |
| 428 | 1168 break; |
| 1169 | |
| 1170 case Bsymbol_function: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1171 TOP_LVALUE = Fsymbol_function (TOP); |
| 428 | 1172 break; |
| 1173 | |
| 1174 case Bget: | |
| 1175 { | |
| 1176 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1177 TOP_LVALUE = Fget (TOP, arg, Qnil); |
| 428 | 1178 break; |
| 1179 } | |
| 1180 | |
| 1181 case Bsub1: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1182 { |
| 1983 | 1183 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1184 TOP_LVALUE = Fsub1 (TOP); |
| 1983 | 1185 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1186 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1187 TOP_LVALUE = INTP (arg) ? INT_MINUS1 (arg) : Fsub1 (arg); |
| 1983 | 1188 #endif |
| 428 | 1189 break; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1190 } |
| 428 | 1191 case Badd1: |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1192 { |
| 1983 | 1193 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1194 TOP_LVALUE = Fadd1 (TOP); |
| 1983 | 1195 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1196 Lisp_Object arg = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1197 TOP_LVALUE = INTP (arg) ? INT_PLUS1 (arg) : Fadd1 (arg); |
| 1983 | 1198 #endif |
| 428 | 1199 break; |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1200 } |
| 428 | 1201 |
| 1202 case Beqlsign: | |
| 1203 { | |
| 1204 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1205 TOP_LVALUE = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil; |
| 428 | 1206 break; |
| 1207 } | |
| 1208 | |
| 1209 case Bgtr: | |
| 1210 { | |
| 1211 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1212 TOP_LVALUE = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil; |
| 428 | 1213 break; |
| 1214 } | |
| 1215 | |
| 1216 case Blss: | |
| 1217 { | |
| 1218 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1219 TOP_LVALUE = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil; |
| 428 | 1220 break; |
| 1221 } | |
| 1222 | |
| 1223 case Bleq: | |
| 1224 { | |
| 1225 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1226 TOP_LVALUE = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil; |
| 428 | 1227 break; |
| 1228 } | |
| 1229 | |
| 1230 case Bgeq: | |
| 1231 { | |
| 1232 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1233 TOP_LVALUE = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil; |
| 428 | 1234 break; |
| 1235 } | |
| 1236 | |
| 1237 | |
| 1238 case Bnegate: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1239 TOP_LVALUE = bytecode_negate (TOP); |
| 428 | 1240 break; |
| 1241 | |
| 1242 case Bnconc: | |
| 1243 DISCARD (1); | |
| 1920 | 1244 /* nconc2 GCPROs before calling this. */ |
| 1245 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1246 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1247 TOP_LVALUE = bytecode_nconc2 (TOP_ADDRESS); |
| 428 | 1248 break; |
| 1249 | |
| 1250 case Bplus: | |
| 1251 { | |
| 1252 Lisp_Object arg2 = POP; | |
| 1253 Lisp_Object arg1 = TOP; | |
| 1983 | 1254 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1255 TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode); |
| 1983 | 1256 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1257 TOP_LVALUE = INTP (arg1) && INTP (arg2) ? |
| 428 | 1258 INT_PLUS (arg1, arg2) : |
| 1259 bytecode_arithop (arg1, arg2, opcode); | |
| 1983 | 1260 #endif |
| 428 | 1261 break; |
| 1262 } | |
| 1263 | |
| 1264 case Bdiff: | |
| 1265 { | |
| 1266 Lisp_Object arg2 = POP; | |
| 1267 Lisp_Object arg1 = TOP; | |
| 1983 | 1268 #ifdef HAVE_BIGNUM |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1269 TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode); |
| 1983 | 1270 #else |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1271 TOP_LVALUE = INTP (arg1) && INTP (arg2) ? |
| 428 | 1272 INT_MINUS (arg1, arg2) : |
| 1273 bytecode_arithop (arg1, arg2, opcode); | |
| 1983 | 1274 #endif |
| 428 | 1275 break; |
| 1276 } | |
| 1277 | |
| 1278 case Bmult: | |
| 1279 case Bquo: | |
| 1280 case Bmax: | |
| 1281 case Bmin: | |
| 1282 { | |
| 1283 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1284 TOP_LVALUE = bytecode_arithop (TOP, arg, opcode); |
| 428 | 1285 break; |
| 1286 } | |
| 1287 | |
| 1288 case Bpoint: | |
| 1289 PUSH (make_int (BUF_PT (current_buffer))); | |
| 1290 break; | |
| 1291 | |
| 1292 case Binsert: | |
| 1920 | 1293 /* Says it can GC. */ |
| 1294 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1295 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1296 TOP_LVALUE = Finsert (1, TOP_ADDRESS); |
| 428 | 1297 break; |
| 1298 | |
| 1299 case BinsertN: | |
| 1300 n = READ_UINT_1; | |
| 1301 DISCARD (n - 1); | |
| 1920 | 1302 /* See Binsert. */ |
| 1303 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1304 TOP_LVALUE = TOP; /* Ignore multiple values. */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1305 TOP_LVALUE = Finsert (n, TOP_ADDRESS); |
| 428 | 1306 break; |
| 1307 | |
| 1308 case Baref: | |
| 1309 { | |
| 1310 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1311 TOP_LVALUE = Faref (TOP, arg); |
| 428 | 1312 break; |
| 1313 } | |
| 1314 | |
| 1315 case Bmemq: | |
| 1316 { | |
| 1317 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1318 TOP_LVALUE = Fmemq (TOP, arg); |
| 428 | 1319 break; |
| 1320 } | |
| 1321 | |
| 1322 case Bset: | |
| 1323 { | |
| 1324 Lisp_Object arg = POP; | |
| 1884 | 1325 /* Fset may call magic handlers */ |
| 1326 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1327 TOP_LVALUE = Fset (TOP, arg); |
| 428 | 1328 break; |
| 1329 } | |
| 1330 | |
| 1331 case Bequal: | |
| 1332 { | |
| 1333 Lisp_Object arg = POP; | |
| 1920 | 1334 /* Can QUIT, so can GC, right? */ |
| 1335 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1336 TOP_LVALUE = Fequal (TOP, arg); |
| 428 | 1337 break; |
| 1338 } | |
| 1339 | |
| 1340 case Bnthcdr: | |
| 1341 { | |
| 1342 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1343 TOP_LVALUE = Fnthcdr (TOP, arg); |
| 428 | 1344 break; |
| 1345 } | |
| 1346 | |
| 1347 case Belt: | |
| 1348 { | |
| 1349 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1350 TOP_LVALUE = Felt (TOP, arg); |
| 428 | 1351 break; |
| 1352 } | |
| 1353 | |
| 1354 case Bmember: | |
| 1355 { | |
| 1356 Lisp_Object arg = POP; | |
| 1920 | 1357 /* Can QUIT, so can GC, right? */ |
| 1358 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1359 TOP_LVALUE = Fmember (TOP, arg); |
| 428 | 1360 break; |
| 1361 } | |
| 1362 | |
| 1363 case Bgoto_char: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1364 TOP_LVALUE = Fgoto_char (TOP, Qnil); |
| 428 | 1365 break; |
| 1366 | |
| 1367 case Bcurrent_buffer: | |
| 1368 { | |
| 793 | 1369 Lisp_Object buffer = wrap_buffer (current_buffer); |
| 1370 | |
| 428 | 1371 PUSH (buffer); |
| 1372 break; | |
| 1373 } | |
| 1374 | |
| 1375 case Bset_buffer: | |
| 1884 | 1376 /* #### WAG: set-buffer may cause Fset's of buffer locals |
| 1377 Didn't prevent crash. :-( */ | |
| 1378 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1379 TOP_LVALUE = Fset_buffer (TOP); |
| 428 | 1380 break; |
| 1381 | |
| 1382 case Bpoint_max: | |
| 1383 PUSH (make_int (BUF_ZV (current_buffer))); | |
| 1384 break; | |
| 1385 | |
| 1386 case Bpoint_min: | |
| 1387 PUSH (make_int (BUF_BEGV (current_buffer))); | |
| 1388 break; | |
| 1389 | |
| 1390 case Bskip_chars_forward: | |
| 1391 { | |
| 1392 Lisp_Object arg = POP; | |
| 1920 | 1393 /* Can QUIT, so can GC, right? */ |
| 1394 /* GCPRO_STACK; */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1395 TOP_LVALUE = Fskip_chars_forward (TOP, arg, Qnil); |
| 428 | 1396 break; |
| 1397 } | |
| 1398 | |
| 1399 case Bassq: | |
| 1400 { | |
| 1401 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1402 TOP_LVALUE = Fassq (TOP, arg); |
| 428 | 1403 break; |
| 1404 } | |
| 1405 | |
| 1406 case Bsetcar: | |
| 1407 { | |
| 1408 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1409 TOP_LVALUE = Fsetcar (TOP, arg); |
| 428 | 1410 break; |
| 1411 } | |
| 1412 | |
| 1413 case Bsetcdr: | |
| 1414 { | |
| 1415 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1416 TOP_LVALUE = Fsetcdr (TOP, arg); |
| 428 | 1417 break; |
| 1418 } | |
| 1419 | |
| 1420 case Bnreverse: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1421 TOP_LVALUE = bytecode_nreverse (TOP); |
| 428 | 1422 break; |
| 1423 | |
| 1424 case Bcar_safe: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1425 TOP_LVALUE = CONSP (TOP) ? XCAR (TOP) : Qnil; |
| 428 | 1426 break; |
| 1427 | |
| 1428 case Bcdr_safe: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1429 TOP_LVALUE = CONSP (TOP) ? XCDR (TOP) : Qnil; |
| 428 | 1430 break; |
| 1431 | |
| 1432 } | |
| 1433 } | |
| 1434 } | |
| 1435 | |
| 1436 /* It makes a worthwhile performance difference (5%) to shunt | |
| 1437 lesser-used opcodes off to a subroutine, to keep the switch in | |
| 1438 execute_optimized_program small. If you REALLY care about | |
| 1439 performance, you want to keep your heavily executed code away from | |
| 1440 rarely executed code, to minimize cache misses. | |
| 1441 | |
| 1442 Don't make this function static, since then the compiler might inline it. */ | |
| 1443 Lisp_Object * | |
| 1444 execute_rare_opcode (Lisp_Object *stack_ptr, | |
| 2286 | 1445 const Opbyte *UNUSED (program_ptr), |
| 428 | 1446 Opcode opcode) |
| 1447 { | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1448 REGISTER int n; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1449 |
| 428 | 1450 switch (opcode) |
| 1451 { | |
| 1452 | |
| 1453 case Bsave_excursion: | |
| 1454 record_unwind_protect (save_excursion_restore, | |
| 1455 save_excursion_save ()); | |
| 1456 break; | |
| 1457 | |
|
4775
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1458 /* This bytecode will eventually go away, once we no longer encounter |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1459 byte code from 21.4. In 21.5.10 and newer, save-window-excursion is |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1460 a macro. */ |
| 428 | 1461 case Bsave_window_excursion: |
| 1462 { | |
| 1463 int count = specpdl_depth (); | |
|
4775
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1464 record_unwind_protect (Feval, |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1465 list2 (Qset_window_configuration, |
|
1d61580e0cf7
Remove Fsave_window_excursion from window.c, it's overridden by Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4717
diff
changeset
|
1466 call0 (Qcurrent_window_configuration))); |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1467 TOP_LVALUE = Fprogn (TOP); |
| 771 | 1468 unbind_to (count); |
| 428 | 1469 break; |
| 1470 } | |
| 1471 | |
| 1472 case Bsave_restriction: | |
| 1473 record_unwind_protect (save_restriction_restore, | |
| 844 | 1474 save_restriction_save (current_buffer)); |
| 428 | 1475 break; |
| 1476 | |
| 1477 case Bcatch: | |
| 1478 { | |
| 1479 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1480 TOP_LVALUE = internal_catch (TOP, Feval, arg, 0, 0, 0); |
| 428 | 1481 break; |
| 1482 } | |
| 1483 | |
| 1484 case Bskip_chars_backward: | |
| 1485 { | |
| 1486 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1487 TOP_LVALUE = Fskip_chars_backward (TOP, arg, Qnil); |
| 428 | 1488 break; |
| 1489 } | |
| 1490 | |
| 1491 case Bunwind_protect: | |
| 1492 record_unwind_protect (Fprogn, POP); | |
| 1493 break; | |
| 1494 | |
| 1495 case Bcondition_case: | |
| 1496 { | |
| 1497 Lisp_Object arg2 = POP; /* handlers */ | |
| 1498 Lisp_Object arg1 = POP; /* bodyform */ | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1499 TOP_LVALUE = condition_case_3 (arg1, TOP, arg2); |
| 428 | 1500 break; |
| 1501 } | |
| 1502 | |
| 1503 case Bset_marker: | |
| 1504 { | |
| 1505 Lisp_Object arg2 = POP; | |
| 1506 Lisp_Object arg1 = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1507 TOP_LVALUE = Fset_marker (TOP, arg1, arg2); |
| 428 | 1508 break; |
| 1509 } | |
| 1510 | |
| 1511 case Brem: | |
| 1512 { | |
| 1513 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1514 TOP_LVALUE = Frem (TOP, arg); |
| 428 | 1515 break; |
| 1516 } | |
| 1517 | |
| 1518 case Bmatch_beginning: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1519 TOP_LVALUE = Fmatch_beginning (TOP); |
| 428 | 1520 break; |
| 1521 | |
| 1522 case Bmatch_end: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1523 TOP_LVALUE = Fmatch_end (TOP); |
| 428 | 1524 break; |
| 1525 | |
| 1526 case Bupcase: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1527 TOP_LVALUE = Fupcase (TOP, Qnil); |
| 428 | 1528 break; |
| 1529 | |
| 1530 case Bdowncase: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1531 TOP_LVALUE = Fdowncase (TOP, Qnil); |
| 428 | 1532 break; |
| 1533 | |
| 1534 case Bfset: | |
| 1535 { | |
| 1536 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1537 TOP_LVALUE = Ffset (TOP, arg); |
| 428 | 1538 break; |
| 1539 } | |
| 1540 | |
| 1541 case Bstring_equal: | |
| 1542 { | |
| 1543 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1544 TOP_LVALUE = Fstring_equal (TOP, arg); |
| 428 | 1545 break; |
| 1546 } | |
| 1547 | |
| 1548 case Bstring_lessp: | |
| 1549 { | |
| 1550 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1551 TOP_LVALUE = Fstring_lessp (TOP, arg); |
| 428 | 1552 break; |
| 1553 } | |
| 1554 | |
| 1555 case Bsubstring: | |
| 1556 { | |
| 1557 Lisp_Object arg2 = POP; | |
| 1558 Lisp_Object arg1 = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1559 TOP_LVALUE = Fsubstring (TOP, arg1, arg2); |
| 428 | 1560 break; |
| 1561 } | |
| 1562 | |
| 1563 case Bcurrent_column: | |
| 1564 PUSH (make_int (current_column (current_buffer))); | |
| 1565 break; | |
| 1566 | |
| 1567 case Bchar_after: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1568 TOP_LVALUE = Fchar_after (TOP, Qnil); |
| 428 | 1569 break; |
| 1570 | |
| 1571 case Bindent_to: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1572 TOP_LVALUE = Findent_to (TOP, Qnil, Qnil); |
| 428 | 1573 break; |
| 1574 | |
| 1575 case Bwiden: | |
| 1576 PUSH (Fwiden (Qnil)); | |
| 1577 break; | |
| 1578 | |
| 1579 case Bfollowing_char: | |
| 1580 PUSH (Ffollowing_char (Qnil)); | |
| 1581 break; | |
| 1582 | |
| 1583 case Bpreceding_char: | |
| 1584 PUSH (Fpreceding_char (Qnil)); | |
| 1585 break; | |
| 1586 | |
| 1587 case Beolp: | |
| 1588 PUSH (Feolp (Qnil)); | |
| 1589 break; | |
| 1590 | |
| 1591 case Beobp: | |
| 1592 PUSH (Feobp (Qnil)); | |
| 1593 break; | |
| 1594 | |
| 1595 case Bbolp: | |
| 1596 PUSH (Fbolp (Qnil)); | |
| 1597 break; | |
| 1598 | |
| 1599 case Bbobp: | |
| 1600 PUSH (Fbobp (Qnil)); | |
| 1601 break; | |
| 1602 | |
| 1603 case Bsave_current_buffer: | |
| 1604 record_unwind_protect (save_current_buffer_restore, | |
| 1605 Fcurrent_buffer ()); | |
| 1606 break; | |
| 1607 | |
| 1608 case Binteractive_p: | |
| 1609 PUSH (Finteractive_p ()); | |
| 1610 break; | |
| 1611 | |
| 1612 case Bforward_char: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1613 TOP_LVALUE = Fforward_char (TOP, Qnil); |
| 428 | 1614 break; |
| 1615 | |
| 1616 case Bforward_word: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1617 TOP_LVALUE = Fforward_word (TOP, Qnil); |
| 428 | 1618 break; |
| 1619 | |
| 1620 case Bforward_line: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1621 TOP_LVALUE = Fforward_line (TOP, Qnil); |
| 428 | 1622 break; |
| 1623 | |
| 1624 case Bchar_syntax: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1625 TOP_LVALUE = Fchar_syntax (TOP, Qnil); |
| 428 | 1626 break; |
| 1627 | |
| 1628 case Bbuffer_substring: | |
| 1629 { | |
| 1630 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1631 TOP_LVALUE = Fbuffer_substring (TOP, arg, Qnil); |
| 428 | 1632 break; |
| 1633 } | |
| 1634 | |
| 1635 case Bdelete_region: | |
| 1636 { | |
| 1637 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1638 TOP_LVALUE = Fdelete_region (TOP, arg, Qnil); |
| 428 | 1639 break; |
| 1640 } | |
| 1641 | |
| 1642 case Bnarrow_to_region: | |
| 1643 { | |
| 1644 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1645 TOP_LVALUE = Fnarrow_to_region (TOP, arg, Qnil); |
| 428 | 1646 break; |
| 1647 } | |
| 1648 | |
| 1649 case Bend_of_line: | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1650 TOP_LVALUE = Fend_of_line (TOP, Qnil); |
| 428 | 1651 break; |
| 1652 | |
| 1653 case Btemp_output_buffer_setup: | |
| 1654 temp_output_buffer_setup (TOP); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1655 TOP_LVALUE = Vstandard_output; |
| 428 | 1656 break; |
| 1657 | |
| 1658 case Btemp_output_buffer_show: | |
| 1659 { | |
| 1660 Lisp_Object arg = POP; | |
| 1661 temp_output_buffer_show (TOP, Qnil); | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1662 TOP_LVALUE = arg; |
| 428 | 1663 /* GAG ME!! */ |
| 1664 /* pop binding of standard-output */ | |
| 771 | 1665 unbind_to (specpdl_depth() - 1); |
| 428 | 1666 break; |
| 1667 } | |
| 1668 | |
| 1669 case Bold_eq: | |
| 1670 { | |
| 1671 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1672 TOP_LVALUE = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil; |
| 428 | 1673 break; |
| 1674 } | |
| 1675 | |
| 1676 case Bold_memq: | |
| 1677 { | |
| 1678 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1679 TOP_LVALUE = Fold_memq (TOP, arg); |
| 428 | 1680 break; |
| 1681 } | |
| 1682 | |
| 1683 case Bold_equal: | |
| 1684 { | |
| 1685 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1686 TOP_LVALUE = Fold_equal (TOP, arg); |
| 428 | 1687 break; |
| 1688 } | |
| 1689 | |
| 1690 case Bold_member: | |
| 1691 { | |
| 1692 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1693 TOP_LVALUE = Fold_member (TOP, arg); |
| 428 | 1694 break; |
| 1695 } | |
| 1696 | |
| 1697 case Bold_assq: | |
| 1698 { | |
| 1699 Lisp_Object arg = POP; | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1700 TOP_LVALUE = Fold_assq (TOP, arg); |
| 428 | 1701 break; |
| 1702 } | |
| 1703 | |
|
4677
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1704 case Bbind_multiple_value_limits: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1705 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1706 Lisp_Object upper = POP, first = TOP, speccount; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1707 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1708 CHECK_NATNUM (upper); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1709 CHECK_NATNUM (first); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1710 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1711 speccount = make_int (bind_multiple_value_limits (XINT (first), |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1712 XINT (upper))); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1713 PUSH (upper); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1714 PUSH (speccount); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1715 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1716 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1717 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1718 case Bmultiple_value_call: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1719 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1720 n = XINT (POP); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1721 DISCARD_PRESERVING_MULTIPLE_VALUES (n - 1); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1722 /* Discard multiple values for the first (function) argument: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1723 TOP_LVALUE = TOP; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1724 TOP_LVALUE = multiple_value_call (n, TOP_ADDRESS); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1725 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1726 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1727 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1728 case Bmultiple_value_list_internal: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1729 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1730 DISCARD_PRESERVING_MULTIPLE_VALUES (3); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1731 TOP_LVALUE = multiple_value_list_internal (4, TOP_ADDRESS); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1732 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1733 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1734 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1735 case Bthrow: |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1736 { |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1737 Lisp_Object arg = POP_WITH_MULTIPLE_VALUES; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1738 |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1739 /* We never throw to a catch tag that is a multiple value: */ |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1740 throw_or_bomb_out (TOP, arg, 0, Qnil, Qnil); |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1741 break; |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1742 } |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1743 |
| 428 | 1744 default: |
| 2500 | 1745 ABORT(); |
| 428 | 1746 break; |
| 1747 } | |
| 1748 return stack_ptr; | |
| 1749 } | |
| 1750 | |
| 1751 | |
| 563 | 1752 DOESNT_RETURN |
| 867 | 1753 invalid_byte_code (const CIbyte *reason, Lisp_Object frob) |
| 428 | 1754 { |
| 563 | 1755 signal_error (Qinvalid_byte_code, reason, frob); |
| 428 | 1756 } |
| 1757 | |
| 1758 /* Check for valid opcodes. Change this when adding new opcodes. */ | |
| 1759 static void | |
| 1760 check_opcode (Opcode opcode) | |
| 1761 { | |
| 1762 if ((opcode < Bvarref) || | |
| 1763 (opcode == 0251) || | |
| 1764 (opcode > Bassq && opcode < Bconstant)) | |
| 563 | 1765 invalid_byte_code ("invalid opcode in instruction stream", |
| 1766 make_int (opcode)); | |
| 428 | 1767 } |
| 1768 | |
| 1769 /* Check that IDX is a valid offset into the `constants' vector */ | |
| 1770 static void | |
| 1771 check_constants_index (int idx, Lisp_Object constants) | |
| 1772 { | |
| 1773 if (idx < 0 || idx >= XVECTOR_LENGTH (constants)) | |
| 563 | 1774 signal_ferror |
| 1775 (Qinvalid_byte_code, | |
| 1776 "reference %d to constants array out of range 0, %ld", | |
| 428 | 1777 idx, XVECTOR_LENGTH (constants) - 1); |
| 1778 } | |
| 1779 | |
| 1780 /* Get next character from Lisp instructions string. */ | |
| 563 | 1781 #define READ_INSTRUCTION_CHAR(lvalue) do { \ |
| 867 | 1782 (lvalue) = itext_ichar (ptr); \ |
| 1783 INC_IBYTEPTR (ptr); \ | |
| 563 | 1784 *icounts_ptr++ = program_ptr - program; \ |
| 1785 if (lvalue > UCHAR_MAX) \ | |
| 1786 invalid_byte_code \ | |
| 1787 ("Invalid character in byte code string", make_char (lvalue)); \ | |
| 428 | 1788 } while (0) |
| 1789 | |
| 1790 /* Get opcode from Lisp instructions string. */ | |
| 1791 #define READ_OPCODE do { \ | |
| 1792 unsigned int c; \ | |
| 1793 READ_INSTRUCTION_CHAR (c); \ | |
| 1794 opcode = (Opcode) c; \ | |
| 1795 } while (0) | |
| 1796 | |
| 1797 /* Get next operand, a uint8, from Lisp instructions string. */ | |
| 1798 #define READ_OPERAND_1 do { \ | |
| 1799 READ_INSTRUCTION_CHAR (arg); \ | |
| 1800 argsize = 1; \ | |
| 1801 } while (0) | |
| 1802 | |
| 1803 /* Get next operand, a uint16, from Lisp instructions string. */ | |
| 1804 #define READ_OPERAND_2 do { \ | |
| 1805 unsigned int arg1, arg2; \ | |
| 1806 READ_INSTRUCTION_CHAR (arg1); \ | |
| 1807 READ_INSTRUCTION_CHAR (arg2); \ | |
| 1808 arg = arg1 + (arg2 << 8); \ | |
| 1809 argsize = 2; \ | |
| 1810 } while (0) | |
| 1811 | |
| 1812 /* Write 1 byte to PTR, incrementing PTR */ | |
| 1813 #define WRITE_INT8(value, ptr) do { \ | |
| 1814 *((ptr)++) = (value); \ | |
| 1815 } while (0) | |
| 1816 | |
| 1817 /* Write 2 bytes to PTR, incrementing PTR */ | |
| 1818 #define WRITE_INT16(value, ptr) do { \ | |
| 1819 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \ | |
| 1820 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \ | |
| 1821 } while (0) | |
| 1822 | |
| 1823 /* We've changed our minds about the opcode we've already written. */ | |
| 1824 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode)) | |
| 1825 | |
| 1826 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */ | |
| 1827 #define WRITE_NARGS(base_opcode) do { \ | |
| 1828 if (arg <= 5) \ | |
| 1829 { \ | |
| 1830 REWRITE_OPCODE (base_opcode + arg); \ | |
| 1831 } \ | |
| 1832 else if (arg <= UCHAR_MAX) \ | |
| 1833 { \ | |
| 1834 REWRITE_OPCODE (base_opcode + 6); \ | |
| 1835 WRITE_INT8 (arg, program_ptr); \ | |
| 1836 } \ | |
| 1837 else \ | |
| 1838 { \ | |
| 1839 REWRITE_OPCODE (base_opcode + 7); \ | |
| 1840 WRITE_INT16 (arg, program_ptr); \ | |
| 1841 } \ | |
| 1842 } while (0) | |
| 1843 | |
| 1844 /* Encode a constants reference within the opcode, or as a 2-byte operand. */ | |
| 1845 #define WRITE_CONSTANT do { \ | |
| 1846 check_constants_index(arg, constants); \ | |
| 1847 if (arg <= UCHAR_MAX - Bconstant) \ | |
| 1848 { \ | |
| 1849 REWRITE_OPCODE (Bconstant + arg); \ | |
| 1850 } \ | |
| 1851 else \ | |
| 1852 { \ | |
| 1853 REWRITE_OPCODE (Bconstant2); \ | |
| 1854 WRITE_INT16 (arg, program_ptr); \ | |
| 1855 } \ | |
| 1856 } while (0) | |
| 1857 | |
| 1858 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr) | |
| 1859 | |
| 1860 /* Compile byte code instructions into free space provided by caller, with | |
| 1861 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte). | |
| 1862 Returns length of compiled code. */ | |
| 1863 static void | |
| 1864 optimize_byte_code (/* in */ | |
| 1865 Lisp_Object instructions, | |
| 1866 Lisp_Object constants, | |
| 1867 /* out */ | |
| 442 | 1868 Opbyte * const program, |
| 1869 int * const program_length, | |
| 1870 int * const varbind_count) | |
| 428 | 1871 { |
| 647 | 1872 Bytecount instructions_length = XSTRING_LENGTH (instructions); |
| 665 | 1873 Elemcount comfy_size = (Elemcount) (2 * instructions_length); |
| 428 | 1874 |
| 442 | 1875 int * const icounts = alloca_array (int, comfy_size); |
| 428 | 1876 int * icounts_ptr = icounts; |
| 1877 | |
| 1878 /* We maintain a table of jumps in the source code. */ | |
| 1879 struct jump | |
| 1880 { | |
| 1881 int from; | |
| 1882 int to; | |
| 1883 }; | |
| 442 | 1884 struct jump * const jumps = alloca_array (struct jump, comfy_size); |
| 428 | 1885 struct jump *jumps_ptr = jumps; |
| 1886 | |
| 1887 Opbyte *program_ptr = program; | |
| 1888 | |
| 867 | 1889 const Ibyte *ptr = XSTRING_DATA (instructions); |
| 1890 const Ibyte * const end = ptr + instructions_length; | |
| 428 | 1891 |
| 1892 *varbind_count = 0; | |
| 1893 | |
| 1894 while (ptr < end) | |
| 1895 { | |
| 1896 Opcode opcode; | |
| 1897 int arg; | |
| 1898 int argsize = 0; | |
| 1899 READ_OPCODE; | |
| 1900 WRITE_OPCODE; | |
| 1901 | |
| 1902 switch (opcode) | |
| 1903 { | |
| 1904 Lisp_Object val; | |
| 1905 | |
| 1906 case Bvarref+7: READ_OPERAND_2; goto do_varref; | |
| 1907 case Bvarref+6: READ_OPERAND_1; goto do_varref; | |
| 1908 case Bvarref: case Bvarref+1: case Bvarref+2: | |
| 1909 case Bvarref+3: case Bvarref+4: case Bvarref+5: | |
| 1910 arg = opcode - Bvarref; | |
| 1911 do_varref: | |
| 1912 check_constants_index (arg, constants); | |
| 1913 val = XVECTOR_DATA (constants) [arg]; | |
| 1914 if (!SYMBOLP (val)) | |
| 563 | 1915 invalid_byte_code ("variable reference to non-symbol", val); |
| 428 | 1916 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) |
| 563 | 1917 invalid_byte_code ("variable reference to constant symbol", val); |
| 428 | 1918 WRITE_NARGS (Bvarref); |
| 1919 break; | |
| 1920 | |
| 1921 case Bvarset+7: READ_OPERAND_2; goto do_varset; | |
| 1922 case Bvarset+6: READ_OPERAND_1; goto do_varset; | |
| 1923 case Bvarset: case Bvarset+1: case Bvarset+2: | |
| 1924 case Bvarset+3: case Bvarset+4: case Bvarset+5: | |
| 1925 arg = opcode - Bvarset; | |
| 1926 do_varset: | |
| 1927 check_constants_index (arg, constants); | |
| 1928 val = XVECTOR_DATA (constants) [arg]; | |
| 1929 if (!SYMBOLP (val)) | |
| 563 | 1930 wtaerror ("attempt to set non-symbol", val); |
| 428 | 1931 if (EQ (val, Qnil) || EQ (val, Qt)) |
| 563 | 1932 signal_error (Qsetting_constant, 0, val); |
| 428 | 1933 /* Ignore assignments to keywords by converting to Bdiscard. |
| 1934 For backward compatibility only - we'd like to make this an error. */ | |
| 1935 if (SYMBOL_IS_KEYWORD (val)) | |
| 1936 REWRITE_OPCODE (Bdiscard); | |
| 1937 else | |
| 1938 WRITE_NARGS (Bvarset); | |
| 1939 break; | |
| 1940 | |
| 1941 case Bvarbind+7: READ_OPERAND_2; goto do_varbind; | |
| 1942 case Bvarbind+6: READ_OPERAND_1; goto do_varbind; | |
| 1943 case Bvarbind: case Bvarbind+1: case Bvarbind+2: | |
| 1944 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5: | |
| 1945 arg = opcode - Bvarbind; | |
| 1946 do_varbind: | |
| 1947 (*varbind_count)++; | |
| 1948 check_constants_index (arg, constants); | |
| 1949 val = XVECTOR_DATA (constants) [arg]; | |
| 1950 if (!SYMBOLP (val)) | |
| 563 | 1951 wtaerror ("attempt to let-bind non-symbol", val); |
| 428 | 1952 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) |
| 563 | 1953 signal_error (Qsetting_constant, |
| 1954 "attempt to let-bind constant symbol", val); | |
| 428 | 1955 WRITE_NARGS (Bvarbind); |
| 1956 break; | |
| 1957 | |
| 1958 case Bcall+7: READ_OPERAND_2; goto do_call; | |
| 1959 case Bcall+6: READ_OPERAND_1; goto do_call; | |
| 1960 case Bcall: case Bcall+1: case Bcall+2: | |
| 1961 case Bcall+3: case Bcall+4: case Bcall+5: | |
| 1962 arg = opcode - Bcall; | |
| 1963 do_call: | |
| 1964 WRITE_NARGS (Bcall); | |
| 1965 break; | |
| 1966 | |
| 1967 case Bunbind+7: READ_OPERAND_2; goto do_unbind; | |
| 1968 case Bunbind+6: READ_OPERAND_1; goto do_unbind; | |
| 1969 case Bunbind: case Bunbind+1: case Bunbind+2: | |
| 1970 case Bunbind+3: case Bunbind+4: case Bunbind+5: | |
| 1971 arg = opcode - Bunbind; | |
| 1972 do_unbind: | |
| 1973 WRITE_NARGS (Bunbind); | |
| 1974 break; | |
| 1975 | |
| 1976 case Bgoto: | |
| 1977 case Bgotoifnil: | |
| 1978 case Bgotoifnonnil: | |
| 1979 case Bgotoifnilelsepop: | |
| 1980 case Bgotoifnonnilelsepop: | |
| 1981 READ_OPERAND_2; | |
| 1982 /* Make program_ptr-relative */ | |
| 1983 arg += icounts - (icounts_ptr - argsize); | |
| 1984 goto do_jump; | |
| 1985 | |
| 1986 case BRgoto: | |
| 1987 case BRgotoifnil: | |
| 1988 case BRgotoifnonnil: | |
| 1989 case BRgotoifnilelsepop: | |
| 1990 case BRgotoifnonnilelsepop: | |
| 1991 READ_OPERAND_1; | |
| 1992 /* Make program_ptr-relative */ | |
| 1993 arg -= 127; | |
| 1994 do_jump: | |
| 1995 /* Record program-relative goto addresses in `jumps' table */ | |
| 1996 jumps_ptr->from = icounts_ptr - icounts - argsize; | |
| 1997 jumps_ptr->to = jumps_ptr->from + arg; | |
| 1998 jumps_ptr++; | |
| 1999 if (arg >= -1 && arg <= argsize) | |
| 563 | 2000 invalid_byte_code ("goto instruction is its own target", Qunbound); |
| 428 | 2001 if (arg <= SCHAR_MIN || |
| 2002 arg > SCHAR_MAX) | |
| 2003 { | |
| 2004 if (argsize == 1) | |
| 2005 REWRITE_OPCODE (opcode + Bgoto - BRgoto); | |
| 2006 WRITE_INT16 (arg, program_ptr); | |
| 2007 } | |
| 2008 else | |
| 2009 { | |
| 2010 if (argsize == 2) | |
| 2011 REWRITE_OPCODE (opcode + BRgoto - Bgoto); | |
| 2012 WRITE_INT8 (arg, program_ptr); | |
| 2013 } | |
| 2014 break; | |
| 2015 | |
| 2016 case Bconstant2: | |
| 2017 READ_OPERAND_2; | |
| 2018 WRITE_CONSTANT; | |
| 2019 break; | |
| 2020 | |
| 2021 case BlistN: | |
| 2022 case BconcatN: | |
| 2023 case BinsertN: | |
| 2024 READ_OPERAND_1; | |
| 2025 WRITE_INT8 (arg, program_ptr); | |
| 2026 break; | |
| 2027 | |
| 2028 default: | |
| 2029 if (opcode < Bconstant) | |
| 2030 check_opcode (opcode); | |
| 2031 else | |
| 2032 { | |
| 2033 arg = opcode - Bconstant; | |
| 2034 WRITE_CONSTANT; | |
| 2035 } | |
| 2036 break; | |
| 2037 } | |
| 2038 } | |
| 2039 | |
| 2040 /* Fix up jumps table to refer to NEW offsets. */ | |
| 2041 { | |
| 2042 struct jump *j; | |
| 2043 for (j = jumps; j < jumps_ptr; j++) | |
| 2044 { | |
| 2045 #ifdef ERROR_CHECK_BYTE_CODE | |
| 2046 assert (j->from < icounts_ptr - icounts); | |
| 2047 assert (j->to < icounts_ptr - icounts); | |
| 2048 #endif | |
| 2049 j->from = icounts[j->from]; | |
| 2050 j->to = icounts[j->to]; | |
| 2051 #ifdef ERROR_CHECK_BYTE_CODE | |
| 2052 assert (j->from < program_ptr - program); | |
| 2053 assert (j->to < program_ptr - program); | |
| 2054 check_opcode ((Opcode) (program[j->from-1])); | |
| 2055 #endif | |
| 2056 check_opcode ((Opcode) (program[j->to])); | |
| 2057 } | |
| 2058 } | |
| 2059 | |
| 2060 /* Fixup jumps in byte-code until no more fixups needed */ | |
| 2061 { | |
| 2062 int more_fixups_needed = 1; | |
| 2063 | |
| 2064 while (more_fixups_needed) | |
| 2065 { | |
| 2066 struct jump *j; | |
| 2067 more_fixups_needed = 0; | |
| 2068 for (j = jumps; j < jumps_ptr; j++) | |
| 2069 { | |
| 2070 int from = j->from; | |
| 2071 int to = j->to; | |
| 2072 int jump = to - from; | |
| 2073 Opbyte *p = program + from; | |
| 2074 Opcode opcode = (Opcode) p[-1]; | |
| 2075 if (!more_fixups_needed) | |
| 2076 check_opcode ((Opcode) p[jump]); | |
| 2077 assert (to >= 0 && program + to < program_ptr); | |
| 2078 switch (opcode) | |
| 2079 { | |
| 2080 case Bgoto: | |
| 2081 case Bgotoifnil: | |
| 2082 case Bgotoifnonnil: | |
| 2083 case Bgotoifnilelsepop: | |
| 2084 case Bgotoifnonnilelsepop: | |
| 2085 WRITE_INT16 (jump, p); | |
| 2086 break; | |
| 2087 | |
| 2088 case BRgoto: | |
| 2089 case BRgotoifnil: | |
| 2090 case BRgotoifnonnil: | |
| 2091 case BRgotoifnilelsepop: | |
| 2092 case BRgotoifnonnilelsepop: | |
| 2093 if (jump > SCHAR_MIN && | |
| 2094 jump <= SCHAR_MAX) | |
| 2095 { | |
| 2096 WRITE_INT8 (jump, p); | |
| 2097 } | |
| 2098 else /* barf */ | |
| 2099 { | |
| 2100 struct jump *jj; | |
| 2101 for (jj = jumps; jj < jumps_ptr; jj++) | |
| 2102 { | |
| 2103 assert (jj->from < program_ptr - program); | |
| 2104 assert (jj->to < program_ptr - program); | |
| 2105 if (jj->from > from) jj->from++; | |
| 2106 if (jj->to > from) jj->to++; | |
| 2107 } | |
| 2108 p[-1] += Bgoto - BRgoto; | |
| 2109 more_fixups_needed = 1; | |
| 2110 memmove (p+1, p, program_ptr++ - p); | |
| 2111 WRITE_INT16 (jump, p); | |
| 2112 } | |
| 2113 break; | |
| 2114 | |
| 2115 default: | |
| 2500 | 2116 ABORT(); |
| 428 | 2117 break; |
| 2118 } | |
| 2119 } | |
| 2120 } | |
| 2121 } | |
| 2122 | |
| 2123 /* *program_ptr++ = 0; */ | |
| 2124 *program_length = program_ptr - program; | |
| 2125 } | |
| 2126 | |
| 2127 /* Optimize the byte code and store the optimized program, only | |
| 2128 understood by bytecode.c, in an opaque object in the | |
| 2129 instructions slot of the Compiled_Function object. */ | |
| 2130 void | |
| 2131 optimize_compiled_function (Lisp_Object compiled_function) | |
| 2132 { | |
| 2133 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function); | |
| 2134 int program_length; | |
| 2135 int varbind_count; | |
| 2136 Opbyte *program; | |
| 2137 | |
| 1737 | 2138 { |
| 2139 int minargs = 0, maxargs = 0, totalargs = 0; | |
| 2140 int optional_p = 0, rest_p = 0, i = 0; | |
| 2141 { | |
| 2142 LIST_LOOP_2 (arg, f->arglist) | |
| 2143 { | |
| 2144 if (EQ (arg, Qand_optional)) | |
| 2145 optional_p = 1; | |
| 2146 else if (EQ (arg, Qand_rest)) | |
| 2147 rest_p = 1; | |
| 2148 else | |
| 2149 { | |
| 2150 if (rest_p) | |
| 2151 { | |
| 2152 maxargs = MANY; | |
| 2153 totalargs++; | |
| 2154 break; | |
| 2155 } | |
| 2156 if (!optional_p) | |
| 2157 minargs++; | |
| 2158 maxargs++; | |
| 2159 totalargs++; | |
| 2160 } | |
| 2161 } | |
| 2162 } | |
| 2163 | |
| 2164 if (totalargs) | |
| 3092 | 2165 #ifdef NEW_GC |
| 2166 f->arguments = make_compiled_function_args (totalargs); | |
| 2167 #else /* not NEW_GC */ | |
| 1737 | 2168 f->args = xnew_array (Lisp_Object, totalargs); |
| 3092 | 2169 #endif /* not NEW_GC */ |
| 1737 | 2170 |
| 2171 { | |
| 2172 LIST_LOOP_2 (arg, f->arglist) | |
| 2173 { | |
| 2174 if (!EQ (arg, Qand_optional) && !EQ (arg, Qand_rest)) | |
| 3092 | 2175 #ifdef NEW_GC |
| 2176 XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i++] = arg; | |
| 2177 #else /* not NEW_GC */ | |
| 1737 | 2178 f->args[i++] = arg; |
| 3092 | 2179 #endif /* not NEW_GC */ |
| 1737 | 2180 } |
| 2181 } | |
| 2182 | |
| 2183 f->max_args = maxargs; | |
| 2184 f->min_args = minargs; | |
| 2185 f->args_in_array = totalargs; | |
| 2186 } | |
| 2187 | |
| 428 | 2188 /* If we have not actually read the bytecode string |
| 2189 and constants vector yet, fetch them from the file. */ | |
| 2190 if (CONSP (f->instructions)) | |
| 2191 Ffetch_bytecode (compiled_function); | |
| 2192 | |
| 2193 if (STRINGP (f->instructions)) | |
| 2194 { | |
| 826 | 2195 /* XSTRING_LENGTH() is more efficient than string_char_length(), |
| 428 | 2196 which would be slightly more `proper' */ |
| 2197 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions)); | |
| 2198 optimize_byte_code (f->instructions, f->constants, | |
| 2199 program, &program_length, &varbind_count); | |
| 2500 | 2200 f->specpdl_depth = (unsigned short) (XINT (Flength (f->arglist)) + |
| 2201 varbind_count); | |
| 428 | 2202 f->instructions = |
| 440 | 2203 make_opaque (program, program_length * sizeof (Opbyte)); |
| 428 | 2204 } |
| 2205 | |
| 2206 assert (OPAQUEP (f->instructions)); | |
| 2207 } | |
| 2208 | |
| 2209 /************************************************************************/ | |
| 2210 /* The compiled-function object type */ | |
| 2211 /************************************************************************/ | |
| 3092 | 2212 |
| 428 | 2213 static void |
| 2214 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun, | |
| 2215 int escapeflag) | |
| 2216 { | |
| 2217 /* This function can GC */ | |
| 2218 Lisp_Compiled_Function *f = | |
| 2219 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */ | |
| 2220 int docp = f->flags.documentationp; | |
| 2221 int intp = f->flags.interactivep; | |
| 2222 struct gcpro gcpro1, gcpro2; | |
| 2223 GCPRO2 (obj, printcharfun); | |
| 2224 | |
| 826 | 2225 write_c_string (printcharfun, print_readably ? "#[" : "#<compiled-function "); |
| 428 | 2226 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK |
| 2227 if (!print_readably) | |
| 2228 { | |
| 2229 Lisp_Object ann = compiled_function_annotation (f); | |
| 2230 if (!NILP (ann)) | |
| 800 | 2231 write_fmt_string_lisp (printcharfun, "(from %S) ", 1, ann); |
| 428 | 2232 } |
| 2233 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ | |
| 2234 /* COMPILED_ARGLIST = 0 */ | |
| 2235 print_internal (compiled_function_arglist (f), printcharfun, escapeflag); | |
| 2236 | |
| 2237 /* COMPILED_INSTRUCTIONS = 1 */ | |
| 826 | 2238 write_c_string (printcharfun, " "); |
| 428 | 2239 { |
| 2240 struct gcpro ngcpro1; | |
| 2241 Lisp_Object instructions = compiled_function_instructions (f); | |
| 2242 NGCPRO1 (instructions); | |
| 2243 if (STRINGP (instructions) && !print_readably) | |
| 2244 { | |
| 2245 /* We don't usually want to see that junk in the bytecode. */ | |
| 800 | 2246 write_fmt_string (printcharfun, "\"...(%ld)\"", |
| 826 | 2247 (long) string_char_length (instructions)); |
| 428 | 2248 } |
| 2249 else | |
| 2250 print_internal (instructions, printcharfun, escapeflag); | |
| 2251 NUNGCPRO; | |
| 2252 } | |
| 2253 | |
| 2254 /* COMPILED_CONSTANTS = 2 */ | |
| 826 | 2255 write_c_string (printcharfun, " "); |
| 428 | 2256 print_internal (compiled_function_constants (f), printcharfun, escapeflag); |
| 2257 | |
| 2258 /* COMPILED_STACK_DEPTH = 3 */ | |
| 800 | 2259 write_fmt_string (printcharfun, " %d", compiled_function_stack_depth (f)); |
| 428 | 2260 |
| 2261 /* COMPILED_DOC_STRING = 4 */ | |
| 2262 if (docp || intp) | |
| 2263 { | |
| 826 | 2264 write_c_string (printcharfun, " "); |
| 428 | 2265 print_internal (compiled_function_documentation (f), printcharfun, |
| 2266 escapeflag); | |
| 2267 } | |
| 2268 | |
| 2269 /* COMPILED_INTERACTIVE = 5 */ | |
| 2270 if (intp) | |
| 2271 { | |
| 826 | 2272 write_c_string (printcharfun, " "); |
| 428 | 2273 print_internal (compiled_function_interactive (f), printcharfun, |
| 2274 escapeflag); | |
| 2275 } | |
| 2276 | |
| 2277 UNGCPRO; | |
| 826 | 2278 write_c_string (printcharfun, print_readably ? "]" : ">"); |
| 428 | 2279 } |
| 2280 | |
| 2281 | |
| 2282 static Lisp_Object | |
| 2283 mark_compiled_function (Lisp_Object obj) | |
| 2284 { | |
| 2285 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); | |
| 814 | 2286 int i; |
| 428 | 2287 |
| 2288 mark_object (f->instructions); | |
| 2289 mark_object (f->arglist); | |
| 2290 mark_object (f->doc_and_interactive); | |
| 2291 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2292 mark_object (f->annotated); | |
| 2293 #endif | |
| 814 | 2294 for (i = 0; i < f->args_in_array; i++) |
| 3092 | 2295 #ifdef NEW_GC |
| 2296 mark_object (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i]); | |
| 2297 #else /* not NEW_GC */ | |
| 814 | 2298 mark_object (f->args[i]); |
| 3092 | 2299 #endif /* not NEW_GC */ |
| 814 | 2300 |
| 428 | 2301 /* tail-recurse on constants */ |
| 2302 return f->constants; | |
| 2303 } | |
| 2304 | |
| 2305 static int | |
| 2306 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 2307 { | |
| 2308 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1); | |
| 2309 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2); | |
| 2310 return | |
| 2311 (f1->flags.documentationp == f2->flags.documentationp && | |
| 2312 f1->flags.interactivep == f2->flags.interactivep && | |
| 2313 f1->flags.domainp == f2->flags.domainp && /* I18N3 */ | |
| 2314 internal_equal (compiled_function_instructions (f1), | |
| 2315 compiled_function_instructions (f2), depth + 1) && | |
| 2316 internal_equal (f1->constants, f2->constants, depth + 1) && | |
| 2317 internal_equal (f1->arglist, f2->arglist, depth + 1) && | |
| 2318 internal_equal (f1->doc_and_interactive, | |
| 2319 f2->doc_and_interactive, depth + 1)); | |
| 2320 } | |
| 2321 | |
| 665 | 2322 static Hashcode |
| 428 | 2323 compiled_function_hash (Lisp_Object obj, int depth) |
| 2324 { | |
| 2325 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); | |
| 2326 return HASH3 ((f->flags.documentationp << 2) + | |
| 2327 (f->flags.interactivep << 1) + | |
| 2328 f->flags.domainp, | |
| 2329 internal_hash (f->instructions, depth + 1), | |
| 2330 internal_hash (f->constants, depth + 1)); | |
| 2331 } | |
| 2332 | |
| 1204 | 2333 static const struct memory_description compiled_function_description[] = { |
| 814 | 2334 { XD_INT, offsetof (Lisp_Compiled_Function, args_in_array) }, |
| 3092 | 2335 #ifdef NEW_GC |
| 2336 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arguments) }, | |
| 2337 #else /* not NEW_GC */ | |
| 2338 { XD_BLOCK_PTR, offsetof (Lisp_Compiled_Function, args), | |
| 2551 | 2339 XD_INDIRECT (0, 0), { &lisp_object_description } }, |
| 3092 | 2340 #endif /* not NEW_GC */ |
| 440 | 2341 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) }, |
| 2342 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) }, | |
| 2343 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) }, | |
| 2344 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) }, | |
| 428 | 2345 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK |
| 440 | 2346 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) }, |
| 428 | 2347 #endif |
| 2348 { XD_END } | |
| 2349 }; | |
| 2350 | |
| 934 | 2351 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, |
| 2352 1, /*dumpable_flag*/ | |
| 2353 mark_compiled_function, | |
| 2354 print_compiled_function, 0, | |
| 2355 compiled_function_equal, | |
| 2356 compiled_function_hash, | |
| 2357 compiled_function_description, | |
| 2358 Lisp_Compiled_Function); | |
| 3092 | 2359 |
| 428 | 2360 |
| 2361 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* | |
| 2362 Return t if OBJECT is a byte-compiled function object. | |
| 2363 */ | |
| 2364 (object)) | |
| 2365 { | |
| 2366 return COMPILED_FUNCTIONP (object) ? Qt : Qnil; | |
| 2367 } | |
| 2368 | |
| 2369 /************************************************************************/ | |
| 2370 /* compiled-function object accessor functions */ | |
| 2371 /************************************************************************/ | |
| 2372 | |
| 2373 Lisp_Object | |
| 2374 compiled_function_arglist (Lisp_Compiled_Function *f) | |
| 2375 { | |
| 2376 return f->arglist; | |
| 2377 } | |
| 2378 | |
| 2379 Lisp_Object | |
| 2380 compiled_function_instructions (Lisp_Compiled_Function *f) | |
| 2381 { | |
| 2382 if (! OPAQUEP (f->instructions)) | |
| 2383 return f->instructions; | |
| 2384 | |
| 2385 { | |
| 2386 /* Invert action performed by optimize_byte_code() */ | |
| 2387 Lisp_Opaque *opaque = XOPAQUE (f->instructions); | |
| 2388 | |
| 867 | 2389 Ibyte * const buffer = |
| 2367 | 2390 alloca_ibytes (OPAQUE_SIZE (opaque) * MAX_ICHAR_LEN); |
| 867 | 2391 Ibyte *bp = buffer; |
| 428 | 2392 |
| 442 | 2393 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque); |
| 2394 const Opbyte *program_ptr = program; | |
| 2395 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque); | |
| 428 | 2396 |
| 2397 while (program_ptr < program_end) | |
| 2398 { | |
| 2399 Opcode opcode = (Opcode) READ_UINT_1; | |
| 867 | 2400 bp += set_itext_ichar (bp, opcode); |
| 428 | 2401 switch (opcode) |
| 2402 { | |
| 2403 case Bvarref+7: | |
| 2404 case Bvarset+7: | |
| 2405 case Bvarbind+7: | |
| 2406 case Bcall+7: | |
| 2407 case Bunbind+7: | |
| 2408 case Bconstant2: | |
| 867 | 2409 bp += set_itext_ichar (bp, READ_UINT_1); |
| 2410 bp += set_itext_ichar (bp, READ_UINT_1); | |
| 428 | 2411 break; |
| 2412 | |
| 2413 case Bvarref+6: | |
| 2414 case Bvarset+6: | |
| 2415 case Bvarbind+6: | |
| 2416 case Bcall+6: | |
| 2417 case Bunbind+6: | |
| 2418 case BlistN: | |
| 2419 case BconcatN: | |
| 2420 case BinsertN: | |
| 867 | 2421 bp += set_itext_ichar (bp, READ_UINT_1); |
| 428 | 2422 break; |
| 2423 | |
| 2424 case Bgoto: | |
| 2425 case Bgotoifnil: | |
| 2426 case Bgotoifnonnil: | |
| 2427 case Bgotoifnilelsepop: | |
| 2428 case Bgotoifnonnilelsepop: | |
| 2429 { | |
| 2430 int jump = READ_INT_2; | |
| 2431 Opbyte buf2[2]; | |
| 2432 Opbyte *buf2p = buf2; | |
| 2433 /* Convert back to program-relative address */ | |
| 2434 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p); | |
| 867 | 2435 bp += set_itext_ichar (bp, buf2[0]); |
| 2436 bp += set_itext_ichar (bp, buf2[1]); | |
| 428 | 2437 break; |
| 2438 } | |
| 2439 | |
| 2440 case BRgoto: | |
| 2441 case BRgotoifnil: | |
| 2442 case BRgotoifnonnil: | |
| 2443 case BRgotoifnilelsepop: | |
| 2444 case BRgotoifnonnilelsepop: | |
| 867 | 2445 bp += set_itext_ichar (bp, READ_INT_1 + 127); |
| 428 | 2446 break; |
| 2447 | |
| 2448 default: | |
| 2449 break; | |
| 2450 } | |
| 2451 } | |
| 2452 return make_string (buffer, bp - buffer); | |
| 2453 } | |
| 2454 } | |
| 2455 | |
| 2456 Lisp_Object | |
| 2457 compiled_function_constants (Lisp_Compiled_Function *f) | |
| 2458 { | |
| 2459 return f->constants; | |
| 2460 } | |
| 2461 | |
| 2462 int | |
| 2463 compiled_function_stack_depth (Lisp_Compiled_Function *f) | |
| 2464 { | |
| 2465 return f->stack_depth; | |
| 2466 } | |
| 2467 | |
| 2468 /* The compiled_function->doc_and_interactive slot uses the minimal | |
| 2469 number of conses, based on compiled_function->flags; it may take | |
| 2470 any of the following forms: | |
| 2471 | |
| 2472 doc | |
| 2473 interactive | |
| 2474 domain | |
| 2475 (doc . interactive) | |
| 2476 (doc . domain) | |
| 2477 (interactive . domain) | |
| 2478 (doc . (interactive . domain)) | |
| 2479 */ | |
| 2480 | |
| 2481 /* Caller must check flags.interactivep first */ | |
| 2482 Lisp_Object | |
| 2483 compiled_function_interactive (Lisp_Compiled_Function *f) | |
| 2484 { | |
| 2485 assert (f->flags.interactivep); | |
| 2486 if (f->flags.documentationp && f->flags.domainp) | |
| 2487 return XCAR (XCDR (f->doc_and_interactive)); | |
| 2488 else if (f->flags.documentationp) | |
| 2489 return XCDR (f->doc_and_interactive); | |
| 2490 else if (f->flags.domainp) | |
| 2491 return XCAR (f->doc_and_interactive); | |
| 2492 else | |
| 2493 return f->doc_and_interactive; | |
| 2494 } | |
| 2495 | |
| 2496 /* Caller need not check flags.documentationp first */ | |
| 2497 Lisp_Object | |
| 2498 compiled_function_documentation (Lisp_Compiled_Function *f) | |
| 2499 { | |
| 2500 if (! f->flags.documentationp) | |
| 2501 return Qnil; | |
| 2502 else if (f->flags.interactivep && f->flags.domainp) | |
| 2503 return XCAR (f->doc_and_interactive); | |
| 2504 else if (f->flags.interactivep) | |
| 2505 return XCAR (f->doc_and_interactive); | |
| 2506 else if (f->flags.domainp) | |
| 2507 return XCAR (f->doc_and_interactive); | |
| 2508 else | |
| 2509 return f->doc_and_interactive; | |
| 2510 } | |
| 2511 | |
| 2512 /* Caller need not check flags.domainp first */ | |
| 2513 Lisp_Object | |
| 2514 compiled_function_domain (Lisp_Compiled_Function *f) | |
| 2515 { | |
| 2516 if (! f->flags.domainp) | |
| 2517 return Qnil; | |
| 2518 else if (f->flags.documentationp && f->flags.interactivep) | |
| 2519 return XCDR (XCDR (f->doc_and_interactive)); | |
| 2520 else if (f->flags.documentationp) | |
| 2521 return XCDR (f->doc_and_interactive); | |
| 2522 else if (f->flags.interactivep) | |
| 2523 return XCDR (f->doc_and_interactive); | |
| 2524 else | |
| 2525 return f->doc_and_interactive; | |
| 2526 } | |
| 2527 | |
| 2528 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2529 | |
| 2530 Lisp_Object | |
| 2531 compiled_function_annotation (Lisp_Compiled_Function *f) | |
| 2532 { | |
| 2533 return f->annotated; | |
| 2534 } | |
| 2535 | |
| 2536 #endif | |
| 2537 | |
| 2538 /* used only by Snarf-documentation; there must be doc already. */ | |
| 2539 void | |
| 2540 set_compiled_function_documentation (Lisp_Compiled_Function *f, | |
| 2541 Lisp_Object new_doc) | |
| 2542 { | |
| 2543 assert (f->flags.documentationp); | |
| 2544 assert (INTP (new_doc) || STRINGP (new_doc)); | |
| 2545 | |
| 2546 if (f->flags.interactivep && f->flags.domainp) | |
| 2547 XCAR (f->doc_and_interactive) = new_doc; | |
| 2548 else if (f->flags.interactivep) | |
| 2549 XCAR (f->doc_and_interactive) = new_doc; | |
| 2550 else if (f->flags.domainp) | |
| 2551 XCAR (f->doc_and_interactive) = new_doc; | |
| 2552 else | |
| 2553 f->doc_and_interactive = new_doc; | |
| 2554 } | |
| 2555 | |
| 2556 | |
| 2557 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /* | |
| 2558 Return the argument list of the compiled-function object FUNCTION. | |
| 2559 */ | |
| 2560 (function)) | |
| 2561 { | |
| 2562 CHECK_COMPILED_FUNCTION (function); | |
| 2563 return compiled_function_arglist (XCOMPILED_FUNCTION (function)); | |
| 2564 } | |
| 2565 | |
| 2566 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /* | |
| 2567 Return the byte-opcode string of the compiled-function object FUNCTION. | |
| 2568 */ | |
| 2569 (function)) | |
| 2570 { | |
| 2571 CHECK_COMPILED_FUNCTION (function); | |
| 2572 return compiled_function_instructions (XCOMPILED_FUNCTION (function)); | |
| 2573 } | |
| 2574 | |
| 2575 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /* | |
| 2576 Return the constants vector of the compiled-function object FUNCTION. | |
| 2577 */ | |
| 2578 (function)) | |
| 2579 { | |
| 2580 CHECK_COMPILED_FUNCTION (function); | |
| 2581 return compiled_function_constants (XCOMPILED_FUNCTION (function)); | |
| 2582 } | |
| 2583 | |
| 2584 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /* | |
| 444 | 2585 Return the maximum stack depth of the compiled-function object FUNCTION. |
| 428 | 2586 */ |
| 2587 (function)) | |
| 2588 { | |
| 2589 CHECK_COMPILED_FUNCTION (function); | |
| 2590 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function))); | |
| 2591 } | |
| 2592 | |
| 2593 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /* | |
| 2594 Return the doc string of the compiled-function object FUNCTION, if available. | |
| 2595 Functions that had their doc strings snarfed into the DOC file will have | |
| 2596 an integer returned instead of a string. | |
| 2597 */ | |
| 2598 (function)) | |
| 2599 { | |
| 2600 CHECK_COMPILED_FUNCTION (function); | |
| 2601 return compiled_function_documentation (XCOMPILED_FUNCTION (function)); | |
| 2602 } | |
| 2603 | |
| 2604 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /* | |
| 2605 Return the interactive spec of the compiled-function object FUNCTION, or nil. | |
| 2606 If non-nil, the return value will be a list whose first element is | |
| 2607 `interactive' and whose second element is the interactive spec. | |
| 2608 */ | |
| 2609 (function)) | |
| 2610 { | |
| 2611 CHECK_COMPILED_FUNCTION (function); | |
| 2612 return XCOMPILED_FUNCTION (function)->flags.interactivep | |
| 2613 ? list2 (Qinteractive, | |
| 2614 compiled_function_interactive (XCOMPILED_FUNCTION (function))) | |
| 2615 : Qnil; | |
| 2616 } | |
| 2617 | |
| 2618 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2619 | |
| 826 | 2620 DEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /* |
| 428 | 2621 Return the annotation of the compiled-function object FUNCTION, or nil. |
| 2622 The annotation is a piece of information indicating where this | |
| 2623 compiled-function object came from. Generally this will be | |
| 2624 a symbol naming a function; or a string naming a file, if the | |
| 2625 compiled-function object was not defined in a function; or nil, | |
| 2626 if the compiled-function object was not created as a result of | |
| 2627 a `load'. | |
| 2628 */ | |
| 2629 (function)) | |
| 2630 { | |
| 2631 CHECK_COMPILED_FUNCTION (function); | |
| 2632 return compiled_function_annotation (XCOMPILED_FUNCTION (function)); | |
| 2633 } | |
| 2634 | |
| 2635 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ | |
| 2636 | |
| 2637 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /* | |
| 2638 Return the domain of the compiled-function object FUNCTION, or nil. | |
| 2639 This is only meaningful if I18N3 was enabled when emacs was compiled. | |
| 2640 */ | |
| 2641 (function)) | |
| 2642 { | |
| 2643 CHECK_COMPILED_FUNCTION (function); | |
| 2644 return XCOMPILED_FUNCTION (function)->flags.domainp | |
| 2645 ? compiled_function_domain (XCOMPILED_FUNCTION (function)) | |
| 2646 : Qnil; | |
| 2647 } | |
| 2648 | |
| 2649 | |
| 2650 | |
| 2651 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /* | |
| 2652 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now. | |
| 2653 */ | |
| 2654 (function)) | |
| 2655 { | |
| 2656 Lisp_Compiled_Function *f; | |
| 2657 CHECK_COMPILED_FUNCTION (function); | |
| 2658 f = XCOMPILED_FUNCTION (function); | |
| 2659 | |
| 2660 if (OPAQUEP (f->instructions) || STRINGP (f->instructions)) | |
| 2661 return function; | |
| 2662 | |
| 2663 if (CONSP (f->instructions)) | |
| 2664 { | |
| 2665 Lisp_Object tem = read_doc_string (f->instructions); | |
| 2666 if (!CONSP (tem)) | |
| 563 | 2667 signal_error (Qinvalid_byte_code, |
| 2668 "Invalid lazy-loaded byte code", tem); | |
| 428 | 2669 /* v18 or v19 bytecode file. Need to Ebolify. */ |
| 2670 if (f->flags.ebolified && VECTORP (XCDR (tem))) | |
| 2671 ebolify_bytecode_constants (XCDR (tem)); | |
| 2672 f->instructions = XCAR (tem); | |
| 2673 f->constants = XCDR (tem); | |
| 2674 return function; | |
| 2675 } | |
| 2500 | 2676 ABORT (); |
| 801 | 2677 return Qnil; /* not (usually) reached */ |
| 428 | 2678 } |
| 2679 | |
| 2680 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /* | |
| 2681 Convert compiled function FUNCTION into an optimized internal form. | |
| 2682 */ | |
| 2683 (function)) | |
| 2684 { | |
| 2685 Lisp_Compiled_Function *f; | |
| 2686 CHECK_COMPILED_FUNCTION (function); | |
| 2687 f = XCOMPILED_FUNCTION (function); | |
| 2688 | |
| 2689 if (OPAQUEP (f->instructions)) /* Already optimized? */ | |
| 2690 return Qnil; | |
| 2691 | |
| 2692 optimize_compiled_function (function); | |
| 2693 return Qnil; | |
| 2694 } | |
| 2695 | |
| 2696 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /* | |
| 2697 Function used internally in byte-compiled code. | |
| 2698 First argument INSTRUCTIONS is a string of byte code. | |
| 2699 Second argument CONSTANTS is a vector of constants. | |
| 2700 Third argument STACK-DEPTH is the maximum stack depth used in this function. | |
| 2701 If STACK-DEPTH is incorrect, Emacs may crash. | |
| 2702 */ | |
| 2703 (instructions, constants, stack_depth)) | |
| 2704 { | |
| 2705 /* This function can GC */ | |
| 2706 int varbind_count; | |
| 2707 int program_length; | |
| 2708 Opbyte *program; | |
| 2709 | |
| 2710 CHECK_STRING (instructions); | |
| 2711 CHECK_VECTOR (constants); | |
| 2712 CHECK_NATNUM (stack_depth); | |
| 2713 | |
| 2714 /* Optimize the `instructions' string, just like when executing a | |
| 2715 regular compiled function, but don't save it for later since this is | |
| 2716 likely to only be executed once. */ | |
| 2717 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions)); | |
| 2718 optimize_byte_code (instructions, constants, program, | |
| 2719 &program_length, &varbind_count); | |
| 2720 SPECPDL_RESERVE (varbind_count); | |
| 2721 return execute_optimized_program (program, | |
| 2722 XINT (stack_depth), | |
| 2723 XVECTOR_DATA (constants)); | |
| 2724 } | |
| 2725 | |
| 2726 | |
| 2727 void | |
| 2728 syms_of_bytecode (void) | |
| 2729 { | |
| 442 | 2730 INIT_LRECORD_IMPLEMENTATION (compiled_function); |
| 3092 | 2731 #ifdef NEW_GC |
| 2732 INIT_LRECORD_IMPLEMENTATION (compiled_function_args); | |
| 2733 #endif /* NEW_GC */ | |
| 442 | 2734 |
| 2735 DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state); | |
| 563 | 2736 DEFSYMBOL (Qbyte_code); |
| 2737 DEFSYMBOL_MULTIWORD_PREDICATE (Qcompiled_functionp); | |
| 428 | 2738 |
| 2739 DEFSUBR (Fbyte_code); | |
| 2740 DEFSUBR (Ffetch_bytecode); | |
| 2741 DEFSUBR (Foptimize_compiled_function); | |
| 2742 | |
| 2743 DEFSUBR (Fcompiled_function_p); | |
| 2744 DEFSUBR (Fcompiled_function_instructions); | |
| 2745 DEFSUBR (Fcompiled_function_constants); | |
| 2746 DEFSUBR (Fcompiled_function_stack_depth); | |
| 2747 DEFSUBR (Fcompiled_function_arglist); | |
| 2748 DEFSUBR (Fcompiled_function_interactive); | |
| 2749 DEFSUBR (Fcompiled_function_doc_string); | |
| 2750 DEFSUBR (Fcompiled_function_domain); | |
| 2751 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 2752 DEFSUBR (Fcompiled_function_annotation); | |
| 2753 #endif | |
| 2754 | |
| 2755 #ifdef BYTE_CODE_METER | |
| 563 | 2756 DEFSYMBOL (Qbyte_code_meter); |
| 428 | 2757 #endif |
| 2758 } | |
| 2759 | |
| 2760 void | |
| 2761 vars_of_bytecode (void) | |
| 2762 { | |
| 2763 #ifdef BYTE_CODE_METER | |
| 2764 | |
| 2765 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /* | |
| 2766 A vector of vectors which holds a histogram of byte code usage. | |
| 2767 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte | |
| 2768 opcode CODE has been executed. | |
| 2769 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0, | |
| 2770 indicates how many times the byte opcodes CODE1 and CODE2 have been | |
| 2771 executed in succession. | |
| 2772 */ ); | |
| 2773 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /* | |
| 2774 If non-nil, keep profiling information on byte code usage. | |
| 2775 The variable `byte-code-meter' indicates how often each byte opcode is used. | |
| 2776 If a symbol has a property named `byte-code-meter' whose value is an | |
| 2777 integer, it is incremented each time that symbol's function is called. | |
| 2778 */ ); | |
| 2779 | |
| 2780 byte_metering_on = 0; | |
| 2781 Vbyte_code_meter = make_vector (256, Qzero); | |
| 2782 { | |
| 2783 int i = 256; | |
| 2784 while (i--) | |
| 2785 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero); | |
| 2786 } | |
| 2787 #endif /* BYTE_CODE_METER */ | |
| 2788 } |