eval4.c 49 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768
  1. /*
  2. * eval4.c Copyright (C) 1991-96, Codemist Ltd
  3. *
  4. * Bytecode interpreter/main interpreter interfaces
  5. */
  6. /* Signature: 502ad14c 12-Mar-2000 */
  7. #include <stdarg.h>
  8. #include <string.h>
  9. #include <ctype.h>
  10. #include "machine.h"
  11. #include "tags.h"
  12. #include "cslerror.h"
  13. #include "externs.h"
  14. #include "arith.h"
  15. #include "entries.h"
  16. #ifdef TIMEOUT
  17. #include "timeout.h"
  18. #endif
  19. #ifdef DEBUG
  20. int trace_all = 0;
  21. #endif
  22. #define name_from(def) elt(qcdr(def), 0)
  23. static void trace_entering(char *s)
  24. {
  25. int i;
  26. for (i=0; i<trace_depth; i++) trace_printf(" ");
  27. trace_printf(s);
  28. trace_depth++;
  29. }
  30. static void trace_exiting(char *s)
  31. {
  32. int i;
  33. trace_depth--;
  34. trace_printf(s);
  35. }
  36. Lisp_Object MS_CDECL bytecoded0(Lisp_Object def, int nargs, ...)
  37. {
  38. Lisp_Object nil=C_nil;
  39. if (nargs != 0) return error(2, err_wrong_no_args, name_from(def),
  40. fixnum_of_int((int32)nargs));
  41. push2(litvec, codevec);
  42. stackcheck1(2, def);
  43. /*
  44. * The "-2" on the next line is discussed in the file bytes1.c. It is
  45. * part of the mechanism for allowing functions to have a few data bytes
  46. * at the start of the code-vector.
  47. */
  48. #ifdef DEBUG
  49. if (trace_all)
  50. { trace_all = 0;
  51. push(def);
  52. freshline_trace();
  53. trace_entering("Entering ");
  54. loop_print_trace(name_from(def));
  55. trace_printf(" (no args)\n");
  56. trace_all = 1;
  57. nil = C_nil;
  58. if (exception_pending()) { popv(3); return nil; }
  59. pop(def);
  60. }
  61. #endif
  62. def = bytestream_interpret(qcar(def)-2, qcdr(def), stack);
  63. nil = C_nil;
  64. if (exception_pending())
  65. { flip_exception();
  66. pop2(codevec, litvec);
  67. flip_exception();
  68. return nil;
  69. }
  70. pop2(codevec, litvec);
  71. return def;
  72. }
  73. Lisp_Object bytecoded1(Lisp_Object def, Lisp_Object a)
  74. {
  75. Lisp_Object r;
  76. Lisp_Object nil = C_nil;
  77. push3(litvec, codevec, a);
  78. stackcheck1(3, def);
  79. #ifdef DEBUG
  80. if (trace_all)
  81. { trace_all = 0;
  82. push(def);
  83. freshline_trace();
  84. trace_printf("Entering ");
  85. loop_print_trace(name_from(def));
  86. trace_printf("Arg1: ");
  87. loop_print_trace(stack[-1]);
  88. trace_printf("\n");
  89. trace_all = 1;
  90. nil = C_nil;
  91. if (exception_pending()) { popv(4); return nil; }
  92. pop(def);
  93. }
  94. #endif
  95. r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1);
  96. nil = C_nil;
  97. if (exception_pending())
  98. { flip_exception();
  99. /*
  100. * If bytestream_interpret handed back a failure code then the VERY LAST
  101. * thing that it did was to move stack down, in effect losing the argument
  102. * that had been passed to the bytesteam code. But nothing can touch the
  103. * stack between that action and here, so if I quickly increment the
  104. * stack pointer again I can find the argument again - or at least whetever
  105. * value the failed function left in that variable. Yes this does look
  106. * a little delicate, but I do like seeing argument values in my backtraces,
  107. * and the software stack involved here it totally under my control.
  108. * NOTE however that if the function I am calling here does a tail call
  109. * to something that is not directly bytecoded then the stack can be
  110. * clobbered, and the results will be garbage in the backtrace.
  111. */
  112. stack++;
  113. pop3(a, codevec, litvec);
  114. if ((exit_reason & UNWIND_ERROR) != 0)
  115. { err_printf("Arg1: ");
  116. loop_print_error(a); err_printf("\n");
  117. ignore_exception();
  118. }
  119. flip_exception();
  120. return nil;
  121. }
  122. pop2(codevec, litvec);
  123. return r;
  124. }
  125. Lisp_Object bytecoded2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  126. {
  127. Lisp_Object r;
  128. Lisp_Object nil = C_nil;
  129. push4(litvec, codevec, a, b);
  130. stackcheck1(4, def);
  131. #ifdef DEBUG
  132. if (trace_all)
  133. { trace_all = 0;
  134. push(def);
  135. freshline_trace();
  136. trace_printf("Entering ");
  137. loop_print_trace(name_from(def));
  138. trace_printf("Arg1: ");
  139. loop_print_trace(stack[-2]);
  140. trace_printf("\n");
  141. trace_printf("Arg2: ");
  142. loop_print_trace(stack[-1]);
  143. trace_printf("\n");
  144. trace_all = 1;
  145. nil = C_nil;
  146. if (exception_pending()) { popv(5); return nil; }
  147. pop(def);
  148. }
  149. #endif
  150. r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2);
  151. nil = C_nil;
  152. if (exception_pending())
  153. { flip_exception();
  154. stack += 2;
  155. if ((exit_reason & UNWIND_ERROR) != 0)
  156. { err_printf("Arg 1: ");
  157. loop_print_error(stack[-1]); err_printf("\n");
  158. ignore_exception();
  159. err_printf("Arg 2: ");
  160. loop_print_error(stack[0]); err_printf("\n");
  161. ignore_exception();
  162. }
  163. popv(2); pop2(codevec, litvec);
  164. flip_exception();
  165. return nil;
  166. }
  167. pop2(codevec, litvec);
  168. return r;
  169. }
  170. Lisp_Object MS_CDECL bytecoded3(Lisp_Object def, int nargs, ...)
  171. {
  172. va_list aa;
  173. Lisp_Object r, a, b, c;
  174. Lisp_Object nil = C_nil;
  175. if (nargs != 3) return error(2, err_wrong_no_args, name_from(def),
  176. fixnum_of_int((int32)nargs));
  177. va_start(aa, nargs);
  178. a = va_arg(aa, Lisp_Object);
  179. b = va_arg(aa, Lisp_Object);
  180. c = va_arg(aa, Lisp_Object);
  181. va_end(aa);
  182. push5(litvec, codevec, a, b, c);
  183. stackcheck1(5, def);
  184. #ifdef DEBUG
  185. if (trace_all)
  186. { trace_all = 0;
  187. push(def);
  188. freshline_trace();
  189. trace_printf("Entering ");
  190. loop_print_trace(name_from(def));
  191. trace_printf("Arg1: ");
  192. loop_print_trace(stack[-3]);
  193. trace_printf("\n");
  194. trace_printf("Arg2: ");
  195. loop_print_trace(stack[-2]);
  196. trace_printf("\n");
  197. trace_printf("Arg3: ");
  198. loop_print_trace(stack[-1]);
  199. trace_printf("\n");
  200. trace_all = 1;
  201. nil = C_nil;
  202. if (exception_pending()) { popv(6); return nil; }
  203. pop(def);
  204. }
  205. #endif
  206. r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3);
  207. nil = C_nil;
  208. if (exception_pending())
  209. { flip_exception();
  210. stack += 3;
  211. if ((exit_reason & UNWIND_ERROR) != 0)
  212. { err_printf("Arg1: ");
  213. loop_print_error(stack[-2]); err_printf("\n");
  214. ignore_exception();
  215. err_printf("Arg2: ");
  216. loop_print_error(stack[-1]); err_printf("\n");
  217. ignore_exception();
  218. err_printf("Arg3: ");
  219. loop_print_error(stack[0]); err_printf("\n");
  220. ignore_exception();
  221. }
  222. popv(3); pop2(codevec, litvec);
  223. flip_exception();
  224. return nil;
  225. }
  226. pop2(codevec, litvec);
  227. return r;
  228. }
  229. Lisp_Object MS_CDECL bytecodedn(Lisp_Object def, int nargs, ...)
  230. {
  231. /*
  232. * The messing about here is to get the (unknown number of) args
  233. * into a nice neat vector so that they can be indexed into. If I knew
  234. * that the args were in consecutive locations on the stack I could
  235. * probably save a copying operation.
  236. */
  237. Lisp_Object r;
  238. Lisp_Object nil = C_nil;
  239. int i;
  240. Lisp_Object *stack_save = stack;
  241. va_list a;
  242. push2(litvec, codevec);
  243. if (nargs != 0)
  244. { va_start(a, nargs);
  245. push_args(a, nargs);
  246. }
  247. stackcheck1(stack-stack_save, def);
  248. r = qcar(def);
  249. if (nargs != ((unsigned char *)data_of_bps(r))[0])
  250. { popv(nargs+2);
  251. return error(2, err_wrong_no_args, name_from(def),
  252. fixnum_of_int((int32)nargs));
  253. }
  254. r = bytestream_interpret(r-1, qcdr(def), stack-nargs);
  255. nil = C_nil;
  256. if (exception_pending())
  257. { flip_exception();
  258. stack += nargs;
  259. if ((exit_reason & UNWIND_ERROR) != 0)
  260. /*
  261. * Note that in this display if a function had over 50 args then the
  262. * final bunch of them will be bundled up in to a list (as if for &rest).
  263. */
  264. for (i=1; i<=nargs; i++)
  265. { err_printf("Arg%d: ", i);
  266. loop_print_error(stack[i-nargs]); err_printf("\n");
  267. ignore_exception();
  268. }
  269. popv(nargs); pop2(codevec, litvec);
  270. flip_exception();
  271. return nil;
  272. }
  273. pop2(codevec, litvec);
  274. return r;
  275. }
  276. /*
  277. * Now I have carbon copies of the above, but with some print statements
  278. * inserted. These are installed when a function is marked for trace
  279. * output.
  280. */
  281. Lisp_Object unpack_mv(Lisp_Object nil, Lisp_Object r)
  282. {
  283. Lisp_Object *p = &mv_1;
  284. exit_count = 0;
  285. *p = nil;
  286. while (r != nil)
  287. { *p++ = qcar(r);
  288. r = qcdr(r);
  289. exit_count++;
  290. }
  291. return mv_1;
  292. }
  293. Lisp_Object MS_CDECL tracebytecoded0(Lisp_Object def, int nargs, ...)
  294. {
  295. Lisp_Object r, nil=C_nil;
  296. if (nargs != 0) return error(2, err_wrong_no_args, name_from(def),
  297. fixnum_of_int((int32)nargs));
  298. push3(litvec, codevec, def);
  299. freshline_trace();
  300. trace_entering("Entering ");
  301. loop_print_trace(name_from(def));
  302. trace_printf(" (no args)\n");
  303. nil = C_nil;
  304. if (exception_pending()) { popv(3); return nil; }
  305. def = stack[0];
  306. r = bytestream_interpret(qcar(def)-2, qcdr(def), stack);
  307. nil = C_nil;
  308. if (exception_pending())
  309. { flip_exception();
  310. popv(1); pop2(codevec, litvec);
  311. flip_exception();
  312. return nil;
  313. }
  314. #ifdef COMMON
  315. r = Lmv_list(nil, r);
  316. if (exception_pending())
  317. { flip_exception();
  318. popv(1); pop2(codevec, litvec);
  319. flip_exception();
  320. return nil;
  321. }
  322. #endif
  323. pop(def);
  324. push(r);
  325. freshline_trace();
  326. loop_print_trace(name_from(def));
  327. nil = C_nil;
  328. if (!exception_pending())
  329. { trace_printf(" = ");
  330. loop_print_trace(r);
  331. trace_exiting("\n");
  332. }
  333. if (exception_pending())
  334. { flip_exception();
  335. popv(1); pop2(codevec, litvec);
  336. flip_exception();
  337. return nil;
  338. }
  339. pop3(r, codevec, litvec);
  340. #ifdef COMMON
  341. r = unpack_mv(nil, r);
  342. #endif
  343. return r;
  344. }
  345. Lisp_Object tracebytecoded1(Lisp_Object def, Lisp_Object a)
  346. {
  347. Lisp_Object r;
  348. Lisp_Object nil = C_nil;
  349. push4(litvec, codevec, def, a);
  350. freshline_trace();
  351. trace_entering("Entering ");
  352. loop_print_trace(name_from(def));
  353. nil = C_nil;
  354. if (exception_pending())
  355. { flip_exception();
  356. popv(2); pop2(codevec, litvec);
  357. flip_exception();
  358. return nil;
  359. }
  360. trace_printf(" (1 arg)\nArg1: ");
  361. loop_print_trace(stack[0]);
  362. trace_printf("\n");
  363. nil = C_nil;
  364. if (exception_pending())
  365. { flip_exception();
  366. popv(2); pop2(codevec, litvec);
  367. flip_exception();
  368. return nil;
  369. }
  370. stackcheck0(4);
  371. def = stack[-1];
  372. r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1);
  373. nil = C_nil;
  374. if (exception_pending())
  375. { flip_exception();
  376. stack++;
  377. pop(a); popv(1); pop2(codevec, litvec);
  378. if ((exit_reason & UNWIND_ERROR) != 0)
  379. { err_printf("Arg1: ");
  380. loop_print_error(a); err_printf("\n");
  381. ignore_exception();
  382. }
  383. flip_exception();
  384. return nil;
  385. }
  386. #ifdef COMMON
  387. r = Lmv_list(nil, r);
  388. if (exception_pending())
  389. { flip_exception();
  390. popv(1); pop2(codevec, litvec);
  391. flip_exception();
  392. return nil;
  393. }
  394. #endif
  395. pop(def);
  396. push(r);
  397. freshline_trace();
  398. loop_print_trace(name_from(def));
  399. trace_printf(" = ");
  400. loop_print_trace(r);
  401. trace_exiting("\n");
  402. pop3(r, codevec, litvec);
  403. #ifdef COMMON
  404. r = unpack_mv(nil, r);
  405. #endif
  406. return r;
  407. }
  408. Lisp_Object tracebytecoded2(Lisp_Object def,
  409. Lisp_Object a, Lisp_Object b)
  410. {
  411. Lisp_Object r;
  412. Lisp_Object nil = C_nil;
  413. push5(litvec, codevec, def, a, b);
  414. freshline_trace();
  415. trace_entering("Entering ");
  416. loop_print_trace(name_from(def));
  417. nil = C_nil;
  418. if (exception_pending())
  419. { flip_exception();
  420. popv(3); pop2(codevec, litvec);
  421. flip_exception();
  422. return nil;
  423. }
  424. trace_printf(" (2 args)\nArg1: ");
  425. loop_print_trace(stack[-1]);
  426. nil = C_nil;
  427. if (exception_pending())
  428. { flip_exception();
  429. popv(3); pop2(codevec, litvec);
  430. flip_exception();
  431. return nil;
  432. }
  433. trace_printf("\nArg2: ");
  434. loop_print_trace(stack[0]);
  435. trace_printf("\n");
  436. nil = C_nil;
  437. if (exception_pending())
  438. { flip_exception();
  439. popv(3); pop2(codevec, litvec);
  440. flip_exception();
  441. return nil;
  442. }
  443. stackcheck0(5);
  444. def = stack[-2];
  445. r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2);
  446. nil = C_nil;
  447. if (exception_pending())
  448. { flip_exception();
  449. stack += 2;
  450. if ((exit_reason & UNWIND_ERROR) != 0)
  451. { err_printf("Arg1: ");
  452. loop_print_error(stack[-1]); err_printf("\n");
  453. ignore_exception();
  454. err_printf("Arg2: ");
  455. loop_print_error(stack[0]); err_printf("\n");
  456. ignore_exception();
  457. }
  458. popv(3); pop2(codevec, litvec);
  459. flip_exception();
  460. return nil;
  461. }
  462. #ifdef COMMON
  463. r = Lmv_list(nil, r);
  464. if (exception_pending())
  465. { flip_exception();
  466. popv(1); pop2(codevec, litvec);
  467. flip_exception();
  468. return nil;
  469. }
  470. #endif
  471. pop(def);
  472. push(r);
  473. freshline_trace();
  474. loop_print_trace(name_from(def));
  475. trace_printf(" = ");
  476. loop_print_trace(r);
  477. trace_exiting("\n");
  478. pop3(r, codevec, litvec);
  479. #ifdef COMMON
  480. r = unpack_mv(nil, r);
  481. #endif
  482. return r;
  483. }
  484. Lisp_Object MS_CDECL tracebytecoded3(Lisp_Object def, int nargs, ...)
  485. {
  486. va_list aa;
  487. Lisp_Object r, a, b, c;
  488. Lisp_Object nil = C_nil;
  489. if (nargs != 3) return error(2, err_wrong_no_args, name_from(def),
  490. fixnum_of_int((int32)nargs));
  491. va_start(aa, nargs);
  492. a = va_arg(aa, Lisp_Object);
  493. b = va_arg(aa, Lisp_Object);
  494. c = va_arg(aa, Lisp_Object);
  495. va_end(aa);
  496. push2(litvec, codevec);
  497. push4(def, a, b, c);
  498. freshline_trace();
  499. trace_entering("Entering ");
  500. loop_print_trace(name_from(def));
  501. nil = C_nil;
  502. if (exception_pending())
  503. { flip_exception();
  504. popv(4); pop2(codevec, litvec);
  505. flip_exception();
  506. return nil;
  507. }
  508. trace_printf(" (3 args)\nArg1: ");
  509. loop_print_trace(stack[-2]);
  510. nil = C_nil;
  511. if (exception_pending())
  512. { flip_exception();
  513. popv(4); pop2(codevec, litvec);
  514. flip_exception();
  515. return nil;
  516. }
  517. trace_printf("\nArg2: ");
  518. loop_print_trace(stack[-1]);
  519. nil = C_nil;
  520. if (exception_pending())
  521. { flip_exception();
  522. popv(4); pop2(codevec, litvec);
  523. flip_exception();
  524. return nil;
  525. }
  526. trace_printf("\nArg3: ");
  527. loop_print_trace(stack[0]);
  528. trace_printf("\n");
  529. nil = C_nil;
  530. if (exception_pending())
  531. { flip_exception();
  532. popv(4); pop2(codevec, litvec);
  533. flip_exception();
  534. return nil;
  535. }
  536. stackcheck0(6);
  537. def = stack[-3];
  538. r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3);
  539. nil = C_nil;
  540. if (exception_pending())
  541. { flip_exception();
  542. stack += 3;
  543. if ((exit_reason & UNWIND_ERROR) != 0)
  544. { err_printf("Arg1: ");
  545. loop_print_error(stack[-2]); err_printf("\n");
  546. ignore_exception();
  547. err_printf("Arg2: ");
  548. loop_print_error(stack[-1]); err_printf("\n");
  549. ignore_exception();
  550. err_printf("Arg3: ");
  551. loop_print_error(stack[0]); err_printf("\n");
  552. ignore_exception();
  553. }
  554. popv(4); pop2(codevec, litvec);
  555. flip_exception();
  556. return nil;
  557. }
  558. #ifdef COMMON
  559. r = Lmv_list(nil, r);
  560. if (exception_pending())
  561. { flip_exception();
  562. popv(1); pop2(codevec, litvec);
  563. flip_exception();
  564. return nil;
  565. }
  566. #endif
  567. pop(def);
  568. push(r);
  569. freshline_trace();
  570. loop_print_trace(name_from(def));
  571. trace_printf(" = ");
  572. loop_print_trace(r);
  573. trace_exiting("\n");
  574. pop3(r, codevec, litvec);
  575. #ifdef COMMON
  576. r = unpack_mv(nil, r);
  577. #endif
  578. return r;
  579. }
  580. Lisp_Object MS_CDECL tracebytecodedn(Lisp_Object def, int nargs, ...)
  581. {
  582. /*
  583. * The messing about here is to get the (unknown number of) args
  584. * into a nice neat vector so that they can be indexed into. If I knew
  585. * that the args were in consecutive locations on the stack I could
  586. * probably save a copying operation.
  587. */
  588. Lisp_Object r;
  589. Lisp_Object nil = C_nil;
  590. int i;
  591. Lisp_Object *stack_save = stack;
  592. va_list a;
  593. push3(litvec, codevec, def);
  594. if (nargs != 0)
  595. { va_start(a, nargs);
  596. push_args(a, nargs);
  597. }
  598. stackcheck1(stack-stack_save, def);
  599. freshline_trace();
  600. trace_entering("Entering");
  601. loop_print_trace(name_from(def));
  602. trace_printf(" (%d args)\n", nargs);
  603. for (i=1; i<=nargs; i++)
  604. { trace_printf("Arg%d: ", i);
  605. loop_print_trace(stack[i-nargs]);
  606. trace_printf("\n");
  607. }
  608. def = stack[-nargs];
  609. r = qcar(def);
  610. if (nargs != ((unsigned char *)data_of_bps(r))[0])
  611. { popv(nargs+3);
  612. return error(2, err_wrong_no_args, name_from(def),
  613. fixnum_of_int((int32)nargs));
  614. }
  615. r = bytestream_interpret(r-1, qcdr(def), stack-nargs);
  616. nil = C_nil;
  617. if (exception_pending())
  618. { flip_exception();
  619. stack += nargs;
  620. if ((exit_reason & UNWIND_ERROR) != 0)
  621. for (i=1; i<=nargs; i++)
  622. { err_printf("Arg%d: ", i);
  623. loop_print_error(stack[i-nargs]); err_printf("\n");
  624. ignore_exception();
  625. }
  626. popv(nargs+1); pop2(codevec, litvec);
  627. flip_exception();
  628. return nil;
  629. }
  630. #ifdef COMMON
  631. r = Lmv_list(nil, r);
  632. if (exception_pending())
  633. { flip_exception();
  634. popv(1); pop2(codevec, litvec);
  635. flip_exception();
  636. return nil;
  637. }
  638. #endif
  639. pop(def);
  640. push(r);
  641. freshline_trace();
  642. loop_print_trace(name_from(def));
  643. trace_printf(" = ");
  644. loop_print_trace(r);
  645. trace_exiting("\n");
  646. pop3(r, codevec, litvec);
  647. #ifdef COMMON
  648. r = unpack_mv(nil, r);
  649. #endif
  650. return r;
  651. }
  652. int doubled_execution = 0;
  653. Lisp_Object MS_CDECL double_bytecoded0(Lisp_Object def, int nargs, ...)
  654. {
  655. Lisp_Object nil=C_nil;
  656. if (nargs != 0) return error(2, err_wrong_no_args, name_from(def),
  657. fixnum_of_int((int32)nargs));
  658. push2(litvec, codevec);
  659. stackcheck1(2, def);
  660. if (!doubled_execution)
  661. { push3(def, litvec, codevec);
  662. doubled_execution = 1;
  663. bytestream_interpret(qcar(def)-2, qcdr(def), stack);
  664. nil = C_nil;
  665. pop3(codevec, litvec, def);
  666. if (!exception_pending())
  667. def = bytestream_interpret(qcar(def)-2, qcdr(def), stack);
  668. doubled_execution = 0;
  669. }
  670. else def = bytestream_interpret(qcar(def)-2, qcdr(def), stack);
  671. nil = C_nil;
  672. if (exception_pending())
  673. { flip_exception();
  674. pop2(codevec, litvec);
  675. flip_exception();
  676. return nil;
  677. }
  678. pop2(codevec, litvec);
  679. return def;
  680. }
  681. Lisp_Object double_bytecoded1(Lisp_Object def, Lisp_Object a)
  682. {
  683. Lisp_Object r;
  684. Lisp_Object nil = C_nil;
  685. push3(litvec, codevec, a);
  686. stackcheck1(3, def);
  687. if (!doubled_execution)
  688. { push4(def, litvec, codevec, a);
  689. doubled_execution = 1;
  690. bytestream_interpret(qcar(def)-2, qcdr(def), stack-1);
  691. nil = C_nil;
  692. pop3(codevec, litvec, def);
  693. if (!exception_pending())
  694. r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1);
  695. doubled_execution = 0;
  696. }
  697. else r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-1);
  698. nil = C_nil;
  699. if (exception_pending())
  700. { flip_exception();
  701. stack++;
  702. pop3(a, codevec, litvec);
  703. if ((exit_reason & UNWIND_ERROR) != 0)
  704. { err_printf("Arg1: ");
  705. loop_print_error(a); err_printf("\n");
  706. ignore_exception();
  707. }
  708. flip_exception();
  709. return nil;
  710. }
  711. pop2(codevec, litvec);
  712. return r;
  713. }
  714. Lisp_Object double_bytecoded2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  715. {
  716. Lisp_Object r;
  717. Lisp_Object nil = C_nil;
  718. push4(litvec, codevec, a, b);
  719. stackcheck1(4, def);
  720. if (!doubled_execution)
  721. { push5(def, litvec, codevec, a, b);
  722. doubled_execution = 1;
  723. bytestream_interpret(qcar(def)-2, qcdr(def), stack-2);
  724. nil = C_nil;
  725. pop3(codevec, litvec, def);
  726. if (!exception_pending())
  727. r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2);
  728. doubled_execution = 0;
  729. }
  730. else r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-2);
  731. nil = C_nil;
  732. if (exception_pending())
  733. { flip_exception();
  734. stack += 2;
  735. if ((exit_reason & UNWIND_ERROR) != 0)
  736. { err_printf("Arg 1: ");
  737. loop_print_error(stack[-1]); err_printf("\n");
  738. ignore_exception();
  739. err_printf("Arg 2: ");
  740. loop_print_error(stack[0]); err_printf("\n");
  741. ignore_exception();
  742. }
  743. popv(2); pop2(codevec, litvec);
  744. flip_exception();
  745. return nil;
  746. }
  747. pop2(codevec, litvec);
  748. return r;
  749. }
  750. Lisp_Object MS_CDECL double_bytecoded3(Lisp_Object def, int nargs, ...)
  751. {
  752. va_list aa;
  753. Lisp_Object r, a, b, c;
  754. Lisp_Object nil = C_nil;
  755. if (nargs != 3) return error(2, err_wrong_no_args, name_from(def),
  756. fixnum_of_int((int32)nargs));
  757. va_start(aa, nargs);
  758. a = va_arg(aa, Lisp_Object);
  759. b = va_arg(aa, Lisp_Object);
  760. c = va_arg(aa, Lisp_Object);
  761. va_end(aa);
  762. push5(litvec, codevec, a, b, c);
  763. stackcheck1(5, def);
  764. if (!doubled_execution)
  765. { push6(def, litvec, codevec, a, b, c);
  766. doubled_execution = 1;
  767. bytestream_interpret(qcar(def)-2, qcdr(def), stack-3);
  768. nil = C_nil;
  769. pop3(codevec, litvec, def);
  770. if (!exception_pending())
  771. r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3);
  772. doubled_execution = 0;
  773. }
  774. else r = bytestream_interpret(qcar(def)-2, qcdr(def), stack-3);
  775. nil = C_nil;
  776. if (exception_pending())
  777. { flip_exception();
  778. stack += 3;
  779. if ((exit_reason & UNWIND_ERROR) != 0)
  780. { err_printf("Arg1: ");
  781. loop_print_error(stack[-2]); err_printf("\n");
  782. ignore_exception();
  783. err_printf("Arg2: ");
  784. loop_print_error(stack[-1]); err_printf("\n");
  785. ignore_exception();
  786. err_printf("Arg3: ");
  787. loop_print_error(stack[0]); err_printf("\n");
  788. ignore_exception();
  789. }
  790. popv(3); pop2(codevec, litvec);
  791. flip_exception();
  792. return nil;
  793. }
  794. pop2(codevec, litvec);
  795. return r;
  796. }
  797. Lisp_Object MS_CDECL double_bytecodedn(Lisp_Object def, int nargs, ...)
  798. {
  799. Lisp_Object r;
  800. Lisp_Object nil = C_nil;
  801. int i;
  802. Lisp_Object *stack_save = stack;
  803. va_list a;
  804. push2(litvec, codevec);
  805. if (nargs != 0)
  806. { va_start(a, nargs);
  807. push_args(a, nargs);
  808. }
  809. stackcheck1(stack-stack_save, def);
  810. r = qcar(def);
  811. if (nargs != ((unsigned char *)data_of_bps(r))[0])
  812. { popv(nargs+2);
  813. return error(2, err_wrong_no_args, name_from(def),
  814. fixnum_of_int((int32)nargs));
  815. }
  816. trace_printf("Function with > 3 args not doubled\n");
  817. r = bytestream_interpret(r-1, qcdr(def), stack-nargs);
  818. nil = C_nil;
  819. if (exception_pending())
  820. { flip_exception();
  821. stack += nargs;
  822. if ((exit_reason & UNWIND_ERROR) != 0)
  823. for (i=1; i<=nargs; i++)
  824. { err_printf("Arg%d: ", i);
  825. loop_print_error(stack[i-nargs]); err_printf("\n");
  826. ignore_exception();
  827. }
  828. popv(nargs); pop2(codevec, litvec);
  829. flip_exception();
  830. return nil;
  831. }
  832. pop2(codevec, litvec);
  833. return r;
  834. }
  835. /*
  836. * The code that follows is just used to support compiled code that
  837. * has &optional or &rest arguments.
  838. */
  839. Lisp_Object byteopt1(Lisp_Object def, Lisp_Object a)
  840. {
  841. return byteoptn(def, 1, a);
  842. }
  843. Lisp_Object byteopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  844. {
  845. return byteoptn(def, 2, a, b);
  846. }
  847. static Lisp_Object vbyteoptn(Lisp_Object def, int nargs,
  848. va_list a, Lisp_Object dflt)
  849. {
  850. Lisp_Object r;
  851. Lisp_Object nil = C_nil;
  852. int i, wantargs, wantopts;
  853. Lisp_Object *stack_save = stack;
  854. push2(litvec, codevec);
  855. /*
  856. * Maybe I should raise an exception (continuable error) if too many args
  857. * are provided - for now I just silently ignore the excess.
  858. */
  859. if (nargs != 0) push_args(a, nargs);
  860. else va_end(a);
  861. stackcheck1(stack-stack_save, def);
  862. r = qcar(def);
  863. wantargs = ((unsigned char *)data_of_bps(r))[0];
  864. wantopts = ((unsigned char *)data_of_bps(r))[1];
  865. if (nargs < wantargs || nargs > wantargs+wantopts)
  866. { popv(nargs); pop2(codevec, litvec)
  867. return error(2, err_wrong_no_args, name_from(def),
  868. fixnum_of_int((int32)nargs));
  869. }
  870. while (nargs < wantargs+wantopts)
  871. { push(dflt); /* Provide value for all optional args */
  872. nargs++;
  873. }
  874. stackcheck1(stack-stack_save, def);
  875. r = qcar(def);
  876. r = bytestream_interpret(r, qcdr(def), stack-nargs);
  877. nil = C_nil;
  878. if (exception_pending())
  879. { flip_exception();
  880. stack += nargs;
  881. if ((exit_reason & UNWIND_ERROR) != 0)
  882. for (i=1; i<=nargs; i++)
  883. { err_printf("Arg%d: ", i);
  884. loop_print_error(stack[i-nargs]); err_printf("\n");
  885. ignore_exception();
  886. }
  887. popv(nargs); pop2(codevec, litvec);
  888. flip_exception();
  889. return nil;
  890. }
  891. pop2(codevec, litvec);
  892. return r;
  893. }
  894. Lisp_Object MS_CDECL byteoptn(Lisp_Object def, int nargs, ...)
  895. {
  896. va_list a;
  897. va_start(a, nargs);
  898. return vbyteoptn(def, nargs, a, C_nil);
  899. }
  900. Lisp_Object hardopt1(Lisp_Object def, Lisp_Object a)
  901. {
  902. return hardoptn(def, 1, a);
  903. }
  904. Lisp_Object hardopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  905. {
  906. return hardoptn(def, 2, a, b);
  907. }
  908. Lisp_Object MS_CDECL hardoptn(Lisp_Object def, int nargs, ...)
  909. {
  910. va_list a;
  911. va_start(a, nargs);
  912. return vbyteoptn(def, nargs, a, SPID_NOARG);
  913. }
  914. Lisp_Object byteoptrest1(Lisp_Object def, Lisp_Object a)
  915. {
  916. return byteoptrestn(def, 1, a);
  917. }
  918. Lisp_Object byteoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  919. {
  920. return byteoptrestn(def, 2, a, b);
  921. }
  922. static Lisp_Object vbyterestn(Lisp_Object def, int nargs,
  923. va_list a, Lisp_Object dflt)
  924. {
  925. Lisp_Object r;
  926. Lisp_Object nil = C_nil;
  927. int i, wantargs, wantopts;
  928. Lisp_Object *stack_save = stack;
  929. push2(litvec, codevec);
  930. if (nargs != 0) push_args(a, nargs);
  931. else va_end(a);
  932. stackcheck1(stack-stack_save, def);
  933. r = qcar(def);
  934. wantargs = ((unsigned char *)data_of_bps(r))[0];
  935. wantopts = ((unsigned char *)data_of_bps(r))[1];
  936. if (nargs < wantargs)
  937. { popv(nargs+2);
  938. return error(2, err_wrong_no_args, name_from(def),
  939. fixnum_of_int((int32)nargs));
  940. }
  941. while (nargs < wantargs+wantopts)
  942. { push(dflt); /* Provide value for all optional args */
  943. nargs++;
  944. }
  945. { Lisp_Object rest = nil;
  946. while (nargs > wantargs+wantopts)
  947. { Lisp_Object w = stack[0];
  948. stack[0] = def;
  949. rest = cons(w, rest);
  950. errexitn(nargs+2);
  951. pop(def);
  952. nargs--;
  953. }
  954. push(rest);
  955. nargs++;
  956. }
  957. stackcheck1(stack-stack_save, def);
  958. r = qcar(def);
  959. r = bytestream_interpret(r, qcdr(def), stack-nargs);
  960. nil = C_nil;
  961. if (exception_pending())
  962. { flip_exception();
  963. stack += nargs;
  964. if ((exit_reason & UNWIND_ERROR) != 0)
  965. for (i=1; i<=nargs; i++)
  966. { err_printf("Arg%d: ", i);
  967. loop_print_error(stack[i-nargs]); err_printf("\n");
  968. ignore_exception();
  969. }
  970. popv(nargs); pop2(codevec, litvec);
  971. flip_exception();
  972. return nil;
  973. }
  974. pop2(codevec, litvec);
  975. return r;
  976. }
  977. Lisp_Object MS_CDECL byteoptrestn(Lisp_Object def, int nargs, ...)
  978. {
  979. va_list a;
  980. va_start(a, nargs);
  981. return vbyterestn(def, nargs, a, C_nil);
  982. }
  983. Lisp_Object hardoptrest1(Lisp_Object def, Lisp_Object a)
  984. {
  985. return hardoptrestn(def, 1, a);
  986. }
  987. Lisp_Object hardoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  988. {
  989. return hardoptrestn(def, 2, a, b);
  990. }
  991. Lisp_Object MS_CDECL hardoptrestn(Lisp_Object def, int nargs, ...)
  992. {
  993. va_list a;
  994. va_start(a, nargs);
  995. return vbyterestn(def, nargs, a, SPID_NOARG);
  996. }
  997. /*
  998. * Next the execution-doubling versions of the &opt/&rest interfaces
  999. */
  1000. Lisp_Object double_byteopt1(Lisp_Object def, Lisp_Object a)
  1001. {
  1002. return double_byteoptn(def, 1, a);
  1003. }
  1004. Lisp_Object double_byteopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  1005. {
  1006. return double_byteoptn(def, 2, a, b);
  1007. }
  1008. static Lisp_Object double_vbyteoptn(Lisp_Object def, int nargs,
  1009. va_list a, Lisp_Object dflt)
  1010. {
  1011. Lisp_Object r;
  1012. Lisp_Object nil = C_nil;
  1013. int i, wantargs, wantopts;
  1014. Lisp_Object *stack_save = stack;
  1015. push2(litvec, codevec);
  1016. /*
  1017. * Maybe I should raise an exception (continuable error) if too many args
  1018. * are provided - for now I just silently ignore th excess.
  1019. */
  1020. if (nargs != 0) push_args(a, nargs);
  1021. else va_end(a);
  1022. stackcheck1(stack-stack_save, def);
  1023. r = qcar(def);
  1024. wantargs = ((unsigned char *)data_of_bps(r))[0];
  1025. wantopts = ((unsigned char *)data_of_bps(r))[1];
  1026. if (nargs < wantargs || nargs > wantargs+wantopts)
  1027. { popv(nargs); pop2(codevec, litvec)
  1028. return error(2, err_wrong_no_args, name_from(def),
  1029. fixnum_of_int((int32)nargs));
  1030. }
  1031. while (nargs < wantargs+wantopts)
  1032. { push(dflt); /* Provide value for all optional args */
  1033. nargs++;
  1034. }
  1035. stackcheck1(stack-stack_save, def);
  1036. trace_printf("Function with simple &opt arg not doubled\n");
  1037. r = qcar(def);
  1038. r = bytestream_interpret(r, qcdr(def), stack-nargs);
  1039. nil = C_nil;
  1040. if (exception_pending())
  1041. { flip_exception();
  1042. stack += nargs;
  1043. if ((exit_reason & UNWIND_ERROR) != 0)
  1044. for (i=1; i<=nargs; i++)
  1045. { err_printf("Arg%d: ", i);
  1046. loop_print_error(stack[i-nargs]); err_printf("\n");
  1047. ignore_exception();
  1048. }
  1049. popv(nargs); pop2(codevec, litvec);
  1050. flip_exception();
  1051. return nil;
  1052. }
  1053. pop2(codevec, litvec);
  1054. return r;
  1055. }
  1056. Lisp_Object MS_CDECL double_byteoptn(Lisp_Object def, int nargs, ...)
  1057. {
  1058. va_list a;
  1059. va_start(a, nargs);
  1060. return double_vbyteoptn(def, nargs, a, C_nil);
  1061. }
  1062. Lisp_Object double_hardopt1(Lisp_Object def, Lisp_Object a)
  1063. {
  1064. return double_hardoptn(def, 1, a);
  1065. }
  1066. Lisp_Object double_hardopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  1067. {
  1068. return double_hardoptn(def, 2, a, b);
  1069. }
  1070. Lisp_Object MS_CDECL double_hardoptn(Lisp_Object def, int nargs, ...)
  1071. {
  1072. va_list a;
  1073. va_start(a, nargs);
  1074. return double_vbyteoptn(def, nargs, a, SPID_NOARG);
  1075. }
  1076. Lisp_Object double_byteoptrest1(Lisp_Object def, Lisp_Object a)
  1077. {
  1078. return double_byteoptrestn(def, 1, a);
  1079. }
  1080. Lisp_Object double_byteoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  1081. {
  1082. return double_byteoptrestn(def, 2, a, b);
  1083. }
  1084. static Lisp_Object double_vbyterestn(Lisp_Object def, int nargs,
  1085. va_list a, Lisp_Object dflt)
  1086. {
  1087. Lisp_Object r;
  1088. Lisp_Object nil = C_nil;
  1089. int i, wantargs, wantopts;
  1090. Lisp_Object *stack_save = stack;
  1091. push2(litvec, codevec);
  1092. if (nargs != 0) push_args(a, nargs);
  1093. else va_end(a);
  1094. stackcheck1(stack-stack_save, def);
  1095. r = qcar(def);
  1096. wantargs = ((unsigned char *)data_of_bps(r))[0];
  1097. wantopts = ((unsigned char *)data_of_bps(r))[1];
  1098. if (nargs < wantargs)
  1099. { popv(nargs+2);
  1100. return error(2, err_wrong_no_args, name_from(def),
  1101. fixnum_of_int((int32)nargs));
  1102. }
  1103. while (nargs < wantargs+wantopts)
  1104. { push(dflt); /* Provide value for all optional args */
  1105. nargs++;
  1106. }
  1107. { Lisp_Object rest = nil;
  1108. while (nargs > wantargs+wantopts)
  1109. { Lisp_Object w = stack[0];
  1110. stack[0] = def;
  1111. rest = cons(w, rest);
  1112. errexitn(nargs+2);
  1113. pop(def);
  1114. nargs--;
  1115. }
  1116. push(rest);
  1117. nargs++;
  1118. }
  1119. stackcheck1(stack-stack_save, def);
  1120. trace_printf("Function with simple &rest arg not doubled\n");
  1121. r = qcar(def);
  1122. r = bytestream_interpret(r, qcdr(def), stack-nargs);
  1123. nil = C_nil;
  1124. if (exception_pending())
  1125. { flip_exception();
  1126. stack += nargs;
  1127. if ((exit_reason & UNWIND_ERROR) != 0)
  1128. for (i=1; i<=nargs; i++)
  1129. { err_printf("Arg%d: ", i);
  1130. loop_print_error(stack[i-nargs]); err_printf("\n");
  1131. ignore_exception();
  1132. }
  1133. popv(nargs); pop2(codevec, litvec);
  1134. flip_exception();
  1135. return nil;
  1136. }
  1137. pop2(codevec, litvec);
  1138. return r;
  1139. }
  1140. Lisp_Object MS_CDECL double_byteoptrestn(Lisp_Object def, int nargs, ...)
  1141. {
  1142. va_list a;
  1143. va_start(a, nargs);
  1144. return double_vbyterestn(def, nargs, a, C_nil);
  1145. }
  1146. Lisp_Object double_hardoptrest1(Lisp_Object def, Lisp_Object a)
  1147. {
  1148. return double_hardoptrestn(def, 1, a);
  1149. }
  1150. Lisp_Object double_hardoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  1151. {
  1152. return double_hardoptrestn(def, 2, a, b);
  1153. }
  1154. Lisp_Object MS_CDECL double_hardoptrestn(Lisp_Object def, int nargs, ...)
  1155. {
  1156. va_list a;
  1157. va_start(a, nargs);
  1158. return double_vbyterestn(def, nargs, a, SPID_NOARG);
  1159. }
  1160. Lisp_Object tracebyteopt1(Lisp_Object def, Lisp_Object a)
  1161. {
  1162. return tracebyteoptn(def, 1, a);
  1163. }
  1164. Lisp_Object tracebyteopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  1165. {
  1166. return tracebyteoptn(def, 2, a, b);
  1167. }
  1168. static Lisp_Object vtracebyteoptn(Lisp_Object def, int nargs,
  1169. va_list a, Lisp_Object dflt)
  1170. {
  1171. Lisp_Object r;
  1172. Lisp_Object nil = C_nil;
  1173. int i, wantargs, wantopts;
  1174. Lisp_Object *stack_save = stack;
  1175. push3(litvec, codevec, def);
  1176. /*
  1177. * Maybe I should raise an exception (continuable error) if too many args
  1178. * are provided - for now I just silently ignore th excess.
  1179. */
  1180. if (nargs != 0) push_args(a, nargs);
  1181. else va_end(a);
  1182. stackcheck1(stack-stack_save, def);
  1183. r = qcar(def);
  1184. wantargs = ((unsigned char *)data_of_bps(r))[0];
  1185. wantopts = ((unsigned char *)data_of_bps(r))[1];
  1186. if (nargs < wantargs || nargs > wantargs+wantopts)
  1187. { popv(nargs+1); pop2(codevec, litvec)
  1188. return error(2, err_wrong_no_args, name_from(def),
  1189. fixnum_of_int((int32)nargs));
  1190. }
  1191. while (nargs < wantargs+wantopts)
  1192. { push(dflt); /* Provide value for all optional args */
  1193. nargs++;
  1194. }
  1195. stackcheck1(stack-stack_save, def);
  1196. freshline_trace();
  1197. loop_print_trace(name_from(def));
  1198. trace_printf(" (%d args)\n", nargs);
  1199. for (i=1; i<=nargs; i++)
  1200. { trace_printf("Arg%d: ", i);
  1201. loop_print_trace(stack[i-nargs]);
  1202. trace_printf("\n");
  1203. }
  1204. def = stack[-nargs];
  1205. r = qcar(def);
  1206. r = bytestream_interpret(r, qcdr(def), stack-nargs);
  1207. nil = C_nil;
  1208. if (exception_pending())
  1209. { flip_exception();
  1210. stack += nargs;
  1211. if ((exit_reason & UNWIND_ERROR) != 0)
  1212. for (i=1; i<=nargs; i++)
  1213. { err_printf("Arg%d: ", i);
  1214. loop_print_error(stack[i-nargs]); err_printf("\n");
  1215. ignore_exception();
  1216. }
  1217. popv(nargs+1); pop2(codevec, litvec);
  1218. flip_exception();
  1219. return nil;
  1220. }
  1221. #ifdef COMMON
  1222. r = Lmv_list(nil, r);
  1223. if (exception_pending())
  1224. { flip_exception();
  1225. popv(1); pop2(codevec, litvec);
  1226. flip_exception();
  1227. return nil;
  1228. }
  1229. #endif
  1230. pop(def);
  1231. push(r);
  1232. freshline_trace();
  1233. loop_print_trace(name_from(def));
  1234. nil = C_nil;
  1235. if (!exception_pending())
  1236. { trace_printf(" = ");
  1237. loop_print_trace(r);
  1238. trace_printf("\n");
  1239. }
  1240. if (exception_pending())
  1241. { flip_exception();
  1242. popv(1); pop2(codevec, litvec);
  1243. flip_exception();
  1244. return nil;
  1245. }
  1246. pop3(r, codevec, litvec);
  1247. #ifdef COMMON
  1248. r = unpack_mv(nil, r);
  1249. #endif
  1250. return r;
  1251. }
  1252. Lisp_Object MS_CDECL tracebyteoptn(Lisp_Object def, int nargs, ...)
  1253. {
  1254. va_list a;
  1255. va_start(a, nargs);
  1256. return vtracebyteoptn(def, nargs, a, C_nil);
  1257. }
  1258. Lisp_Object tracehardopt1(Lisp_Object def, Lisp_Object a)
  1259. {
  1260. return tracehardoptn(def, 1, a);
  1261. }
  1262. Lisp_Object tracehardopt2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  1263. {
  1264. return tracehardoptn(def, 2, a, b);
  1265. }
  1266. Lisp_Object MS_CDECL tracehardoptn(Lisp_Object def, int nargs, ...)
  1267. {
  1268. va_list a;
  1269. va_start(a, nargs);
  1270. return vtracebyteoptn(def, nargs, a, SPID_NOARG);
  1271. }
  1272. Lisp_Object tracebyteoptrest1(Lisp_Object def, Lisp_Object a)
  1273. {
  1274. return tracebyteoptrestn(def, 1, a);
  1275. }
  1276. Lisp_Object tracebyteoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  1277. {
  1278. return tracebyteoptrestn(def, 2, a, b);
  1279. }
  1280. static Lisp_Object vtracebyterestn(Lisp_Object def, int nargs,
  1281. va_list a, Lisp_Object dflt)
  1282. {
  1283. Lisp_Object r;
  1284. Lisp_Object nil = C_nil;
  1285. int i, wantargs, wantopts;
  1286. Lisp_Object *stack_save = stack;
  1287. push3(litvec, codevec, def);
  1288. if (nargs != 0) push_args(a, nargs);
  1289. else va_end(a);
  1290. stackcheck1(stack-stack_save, def);
  1291. r = qcar(def);
  1292. wantargs = ((unsigned char *)data_of_bps(r))[0];
  1293. wantopts = ((unsigned char *)data_of_bps(r))[1];
  1294. if (nargs < wantargs)
  1295. { popv(nargs+2);
  1296. return error(2, err_wrong_no_args, name_from(def),
  1297. fixnum_of_int((int32)nargs));
  1298. }
  1299. while (nargs < wantargs+wantopts)
  1300. { push(dflt); /* Provide value for all optional args */
  1301. nargs++;
  1302. }
  1303. { Lisp_Object rest = nil;
  1304. while (nargs > wantargs+wantopts)
  1305. { Lisp_Object w = stack[0];
  1306. stack[0] = def;
  1307. rest = cons(w, rest);
  1308. errexitn(nargs+2);
  1309. pop(def);
  1310. nargs--;
  1311. }
  1312. push(rest);
  1313. nargs++;
  1314. }
  1315. stackcheck1(stack-stack_save, def);
  1316. freshline_trace();
  1317. loop_print_trace(name_from(def));
  1318. trace_printf(" (%d args)\n", nargs);
  1319. for (i=1; i<=nargs; i++)
  1320. { trace_printf("Arg%d: ", i);
  1321. loop_print_trace(stack[i-nargs]);
  1322. trace_printf("\n");
  1323. }
  1324. def = stack[-nargs];
  1325. r = qcar(def);
  1326. r = bytestream_interpret(r, qcdr(def), stack-nargs);
  1327. nil = C_nil;
  1328. if (exception_pending())
  1329. { flip_exception();
  1330. stack += nargs;
  1331. if ((exit_reason & UNWIND_ERROR) != 0)
  1332. for (i=1; i<=nargs; i++)
  1333. { err_printf("Arg%d: ", i);
  1334. loop_print_error(stack[i-nargs]); err_printf("\n");
  1335. ignore_exception();
  1336. }
  1337. popv(nargs+1); pop2(codevec, litvec);
  1338. flip_exception();
  1339. return nil;
  1340. }
  1341. #ifdef COMMON
  1342. r = Lmv_list(nil, r);
  1343. if (exception_pending())
  1344. { flip_exception();
  1345. popv(1); pop2(codevec, litvec);
  1346. flip_exception();
  1347. return nil;
  1348. }
  1349. #endif
  1350. pop(def);
  1351. push(r);
  1352. freshline_trace();
  1353. loop_print_trace(name_from(def));
  1354. nil = C_nil;
  1355. if (!exception_pending())
  1356. { trace_printf(" = ");
  1357. loop_print_trace(r);
  1358. trace_printf("\n");
  1359. }
  1360. if (exception_pending())
  1361. { flip_exception();
  1362. popv(1); pop2(codevec, litvec);
  1363. flip_exception();
  1364. return nil;
  1365. }
  1366. pop3(r, codevec, litvec);
  1367. #ifdef COMMON
  1368. r = unpack_mv(nil, r);
  1369. #endif
  1370. return r;
  1371. }
  1372. Lisp_Object MS_CDECL tracebyteoptrestn(Lisp_Object def, int nargs, ...)
  1373. {
  1374. va_list a;
  1375. va_start(a, nargs);
  1376. return vtracebyterestn(def, nargs, a, C_nil);
  1377. }
  1378. Lisp_Object tracehardoptrest1(Lisp_Object def, Lisp_Object a)
  1379. {
  1380. return tracehardoptrestn(def, 1, a);
  1381. }
  1382. Lisp_Object tracehardoptrest2(Lisp_Object def, Lisp_Object a, Lisp_Object b)
  1383. {
  1384. return tracehardoptrestn(def, 2, a, b);
  1385. }
  1386. Lisp_Object MS_CDECL tracehardoptrestn(Lisp_Object def, int nargs, ...)
  1387. {
  1388. va_list a;
  1389. va_start(a, nargs);
  1390. return vtracebyterestn(def, nargs, a, SPID_NOARG);
  1391. }
  1392. static Lisp_Object Lis_spid(Lisp_Object nil, Lisp_Object a)
  1393. { /* Used in compilation for optional args */
  1394. return onevalue(Lispify_predicate(is_spid(a)));
  1395. }
  1396. static Lisp_Object Lspid_to_nil(Lisp_Object nil, Lisp_Object a)
  1397. { /* Used in compilation for optional args */
  1398. if (is_spid(a)) a = nil;
  1399. return onevalue(a);
  1400. }
  1401. static Lisp_Object MS_CDECL Lload_spid(Lisp_Object nil, int nargs, ...)
  1402. { /* Used in compilation of UNWIND-PROTECT */
  1403. CSL_IGNORE(nil);
  1404. CSL_IGNORE(nargs);
  1405. return onevalue(SPID_PROTECT);
  1406. }
  1407. Lisp_Object Lmv_list(Lisp_Object nil, Lisp_Object a)
  1408. /*
  1409. * This does a (multiple-value-list A) on just one form. It must be used
  1410. * carefully so that the value-count information does not get lost between
  1411. * the evaluation of A and calling this code.
  1412. */
  1413. {
  1414. #ifdef COMMON
  1415. Lisp_Object r, *save_stack = stack;
  1416. int i, x = exit_count;
  1417. stackcheck1(0, a);
  1418. if (x > 0) push(a);
  1419. for (i=2; i<=x; i++) push((&work_0)[i]);
  1420. r = nil;
  1421. for (i=0; i<x; i++)
  1422. { Lisp_Object w;
  1423. pop(w);
  1424. r = cons(w, r);
  1425. nil = C_nil;
  1426. if (exception_pending())
  1427. { stack = save_stack;
  1428. return nil;
  1429. }
  1430. }
  1431. return onevalue(r);
  1432. #else
  1433. CSL_IGNORE(nil);
  1434. return ncons(a);
  1435. #endif
  1436. }
  1437. /*
  1438. * In these tables there are some functions that would need adjusting
  1439. * for a Common Lisp compiler, since they take different numbers of
  1440. * args in Common and Standard Lisp.
  1441. * This means, to be specific:
  1442. *
  1443. * Lgensym Lread Latan Ltruncate Lfloat
  1444. * Lintern Lmacroexpand Lmacroexpand_1
  1445. * Lrandom Lunintern Lappend Leqn Lgcd
  1446. * Lgeq Lgreaterp Llcm Lleq Llessp
  1447. * Lquotient
  1448. *
  1449. * In these cases (at least!) the Common Lisp version of the compiler will
  1450. * need to avoid generating the call that uses this table.
  1451. *
  1452. * Some functions are missing from the list here because they seemed
  1453. * critical enough to be awarded single-byte opcodes or because the
  1454. * compiler always expands them away - car through cddddr are the main
  1455. * cases, together with eq and equal.
  1456. */
  1457. n_args *zero_arg_functions[] =
  1458. {
  1459. Lbatchp, /* 0 */
  1460. Ldate, /* 1 */
  1461. Leject, /* 2 */
  1462. Lerror0, /* 3 */
  1463. Lgctime, /* 4 */
  1464. Lgensym, /* 5 */
  1465. Llposn, /* 6 */
  1466. Lnext_random, /* 7 */
  1467. Lposn, /* 8 */
  1468. Lread, /* 9 */
  1469. Lreadch, /* 10 */
  1470. Lterpri, /* 11 */
  1471. Ltime, /* 12 */
  1472. Ltyi, /* 13 */
  1473. Lload_spid, /* 14 */ /* ONLY used in compiled code */
  1474. NULL
  1475. };
  1476. one_args *one_arg_functions[] =
  1477. {
  1478. Labsval, /* 0 */
  1479. Ladd1, /* 1 */
  1480. Latan, /* 2 */
  1481. Lapply0, /* 3 */
  1482. Latom, /* 4 */
  1483. Lboundp, /* 5 */
  1484. Lchar_code, /* 6 */
  1485. Lclose, /* 7 */
  1486. Lcodep, /* 8 */
  1487. Lcompress, /* 9 */
  1488. Lconstantp, /* 10 */
  1489. Ldigitp, /* 11 */
  1490. Lendp, /* 12 */
  1491. Leval, /* 13 */
  1492. Levenp, /* 14 */
  1493. Levlis, /* 15 */
  1494. Lexplode, /* 16 */
  1495. Lexplode2lc, /* 17 */
  1496. Lexplodec, /* 18 */
  1497. Lfixp, /* 19 */
  1498. Lfloat, /* 20 */
  1499. Lfloatp, /* 21 */
  1500. Lsymbol_specialp, /* 22 */
  1501. Lgc, /* 23 */
  1502. Lgensym1, /* 24 */
  1503. Lgetenv, /* 25 */
  1504. Lsymbol_globalp, /* 26 */
  1505. Liadd1, /* 27 */
  1506. Lsymbolp, /* 28 */
  1507. Liminus, /* 29 */
  1508. Liminusp, /* 30 */
  1509. Lindirect, /* 31 */
  1510. Lintegerp, /* 32 */
  1511. Lintern, /* 33 */
  1512. Lisub1, /* 34 */
  1513. Llength, /* 35 */
  1514. Llengthc, /* 36 */
  1515. Llinelength, /* 37 */
  1516. Lalpha_char_p, /* 38 */
  1517. Lload_module, /* 39 */
  1518. Llognot, /* 40 */
  1519. Lmacroexpand, /* 41 */
  1520. Lmacroexpand_1, /* 42 */
  1521. Lmacro_function, /* 43 */
  1522. Lget_bps, /* 44 */
  1523. Lmake_global, /* 45 */
  1524. Lsmkvect, /* 46 */
  1525. Lmake_special, /* 47 */
  1526. Lminus, /* 48 */
  1527. Lminusp, /* 49 */
  1528. Lmkvect, /* 50 */
  1529. Lmodular_minus, /* 51 */
  1530. Lmodular_number, /* 52 */
  1531. Lmodular_reciprocal, /* 53 */
  1532. Lnull, /* 54 */
  1533. Loddp, /* 55 */
  1534. Lonep, /* 56 */
  1535. Lpagelength, /* 57 */
  1536. Lconsp, /* 58 */
  1537. Lplist, /* 59 */
  1538. Lplusp, /* 60 */
  1539. Lprin, /* 61 */
  1540. Lprinc, /* 62 */
  1541. Lprint, /* 63 */
  1542. Lprintc, /* 64 */
  1543. Lrandom, /* 65 */
  1544. Lrational, /* 66 */
  1545. Lrdf1, /* 67 */
  1546. Lrds, /* 68 */
  1547. Lremd, /* 69 */
  1548. Lreverse, /* 70 */
  1549. Lnreverse, /* 71 */
  1550. Lwhitespace_char_p, /* 72 */
  1551. Lset_small_modulus, /* 73 */
  1552. Lxtab, /* 74 */
  1553. Lspecial_char, /* 75 */
  1554. Lspecial_form_p, /* 76 */
  1555. Lspool, /* 77 */
  1556. Lstop, /* 78 */
  1557. Lstringp, /* 79 */
  1558. Lsub1, /* 80 */
  1559. Lsymbol_env, /* 81 */
  1560. Lsymbol_function, /* 82 */
  1561. Lsymbol_name, /* 83 */
  1562. Lsymbol_value, /* 84 */
  1563. Lsystem, /* 85 */
  1564. Ltruncate, /* 86 */
  1565. Lttab, /* 87 */
  1566. Ltyo, /* 88 */
  1567. Lunintern, /* 89 */
  1568. Lunmake_global, /* 90 */
  1569. Lunmake_special, /* 91 */
  1570. Lupbv, /* 92 */
  1571. Lsimple_vectorp, /* 93 */
  1572. Lverbos, /* 94 */
  1573. Lwrs, /* 95 */
  1574. Lzerop, /* 96 */
  1575. Lcar, /* 97 */
  1576. Lcdr, /* 98 */
  1577. Lcaar, /* 99 */
  1578. Lcadr, /* 100 */
  1579. Lcdar, /* 101 */
  1580. Lcddr, /* 102 */
  1581. Lcar, /* 103 */ /* Really QCAR (unchecked) */
  1582. Lcdr, /* 104 */
  1583. Lcaar, /* 105 */
  1584. Lcadr, /* 106 */
  1585. Lcdar, /* 107 */
  1586. Lcddr, /* 108 */
  1587. Lncons, /* 109 */
  1588. Lnumberp, /* 110 */
  1589. Lis_spid, /* 111 */ /* ONLY used in compiled code */
  1590. Lspid_to_nil, /* 112 */ /* ONLY used in compiled code */
  1591. Lmv_list, /* 113 */ /* ONLY used in compiled code */
  1592. NULL
  1593. };
  1594. two_args *two_arg_functions[] =
  1595. {
  1596. Lappend, /* 0 */
  1597. Lash, /* 1 */
  1598. Lassoc, /* 2 */
  1599. Latsoc, /* 3 */
  1600. Ldeleq, /* 4 */
  1601. Ldelete, /* 5 */
  1602. Ldivide, /* 6 */
  1603. Leqcar, /* 7 */
  1604. Leql, /* 8 */
  1605. Leqn, /* 9 */
  1606. Lexpt, /* 10 */
  1607. Lflag, /* 11 */
  1608. Lflagpcar, /* 12 */
  1609. Lgcd, /* 13 */
  1610. Lgeq, /* 14 */
  1611. Lgetv, /* 15 */
  1612. Lgreaterp, /* 16 */
  1613. Lidifference, /* 17 */
  1614. Ligreaterp, /* 18 */
  1615. Lilessp, /* 19 */
  1616. Limax, /* 20 */
  1617. Limin, /* 21 */
  1618. Liplus2, /* 22 */
  1619. Liquotient, /* 23 */
  1620. Liremainder, /* 24 */
  1621. Lirightshift, /* 25 */
  1622. Litimes2, /* 26 */
  1623. Llcm, /* 27 */
  1624. Lleq, /* 28 */
  1625. Llessp, /* 29 */
  1626. Lmake_random_state, /* 30 */
  1627. Lmax2, /* 31 */
  1628. Lmember, /* 32 */
  1629. Lmemq, /* 33 */
  1630. Lmin2, /* 34 */
  1631. Lmod, /* 35 */
  1632. Lmodular_difference, /* 36 */
  1633. Lmodular_expt, /* 37 */
  1634. Lmodular_plus, /* 38 */
  1635. Lmodular_quotient, /* 39 */
  1636. Lmodular_times, /* 40 */
  1637. Lnconc, /* 41 */
  1638. Lneq, /* 42 */
  1639. Lorderp, /* 43 */
  1640. Lquotient, /* 44 */
  1641. Lrem, /* 45 */
  1642. Lremflag, /* 46 */
  1643. Lremprop, /* 47 */
  1644. Lrplaca, /* 48 */
  1645. Lrplacd, /* 49 */
  1646. Lsgetv, /* 50 */
  1647. Lset, /* 51 */
  1648. Lsmemq, /* 52 */
  1649. Lsubla, /* 53 */
  1650. Lsublis, /* 54 */
  1651. Lsymbol_set_definition, /* 55 */
  1652. Lsymbol_set_env, /* 56 */
  1653. Ltimes2, /* 57 */
  1654. Lxcons, /* 58 */
  1655. Lequal, /* 59 */
  1656. Leq, /* 60 */
  1657. Lcons, /* 61 */
  1658. Llist2, /* 62 */
  1659. Lget, /* 63 */
  1660. Lgetv, /* 64 */ /* QGETV */
  1661. Lflagp, /* 65 */
  1662. Lapply1, /* 66 */
  1663. Ldifference2, /* 67 */
  1664. Lplus2, /* 68 */
  1665. Ltimes2, /* 69 */
  1666. Lequalcar, /* 70 */
  1667. Leq, /* 71 */ /* IEQUAL */
  1668. NULL
  1669. };
  1670. n_args *three_arg_functions[] =
  1671. {
  1672. Lbpsputv, /* 0 */
  1673. Lerrorsetn, /* 1 */
  1674. Llist2star, /* 2 */
  1675. Llist3, /* 3 */
  1676. Lputprop, /* 4 */
  1677. Lputv, /* 5 */
  1678. Lsputv, /* 6 */
  1679. Lsubst, /* 7 */
  1680. Lapply2, /* 8 */
  1681. Lacons, /* 9 */
  1682. NULL
  1683. };
  1684. /* end of eval4.c */