programs.c 9.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393
  1. /* Copyright 2001,2009-2014,2017-2019
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #if HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include <string.h>
  19. #include "alist.h"
  20. #include "boolean.h"
  21. #include "eval.h"
  22. #include "extensions.h"
  23. #include "gsubr.h"
  24. #include "instructions.h"
  25. #include "modules.h"
  26. #include "numbers.h"
  27. #include "pairs.h"
  28. #include "ports.h"
  29. #include "procprop.h" /* scm_sym_name */
  30. #include "variable.h"
  31. #include "version.h"
  32. #include "vm.h"
  33. #include "programs.h"
  34. static SCM write_program = SCM_BOOL_F;
  35. SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0,
  36. (SCM program),
  37. "")
  38. #define FUNC_NAME s_scm_program_code
  39. {
  40. SCM_VALIDATE_PROGRAM (1, program);
  41. return scm_from_uintptr_t ((uintptr_t) SCM_PROGRAM_CODE (program));
  42. }
  43. #undef FUNC_NAME
  44. SCM
  45. scm_i_program_name (SCM program)
  46. {
  47. static SCM program_name = SCM_BOOL_F;
  48. if (SCM_PRIMITIVE_P (program))
  49. return scm_i_primitive_name (SCM_PROGRAM_CODE (program));
  50. if (scm_is_false (program_name) && scm_module_system_booted_p)
  51. program_name =
  52. scm_c_private_variable ("system vm program", "program-name");
  53. return scm_call_1 (scm_variable_ref (program_name), program);
  54. }
  55. SCM
  56. scm_i_program_documentation (SCM program)
  57. {
  58. static SCM program_documentation = SCM_BOOL_F;
  59. if (SCM_PRIMITIVE_P (program))
  60. return SCM_BOOL_F;
  61. if (scm_is_false (program_documentation) && scm_module_system_booted_p)
  62. program_documentation =
  63. scm_c_private_variable ("system vm program", "program-documentation");
  64. return scm_call_1 (scm_variable_ref (program_documentation), program);
  65. }
  66. SCM
  67. scm_i_program_properties (SCM program)
  68. {
  69. static SCM program_properties = SCM_BOOL_F;
  70. if (SCM_PRIMITIVE_P (program))
  71. {
  72. SCM name = scm_i_program_name (program);
  73. if (scm_is_false (name))
  74. return SCM_EOL;
  75. return scm_acons (scm_sym_name, name, SCM_EOL);
  76. }
  77. if (scm_is_false (program_properties) && scm_module_system_booted_p)
  78. program_properties =
  79. scm_c_private_variable ("system vm program", "program-properties");
  80. return scm_call_1 (scm_variable_ref (program_properties), program);
  81. }
  82. void
  83. scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
  84. {
  85. static int print_error = 0;
  86. if (scm_is_false (write_program) && scm_module_system_booted_p)
  87. write_program = scm_c_private_variable ("system vm program",
  88. "write-program");
  89. if (SCM_PROGRAM_IS_CONTINUATION (program))
  90. {
  91. /* twingliness */
  92. scm_puts ("#<continuation ", port);
  93. scm_uintprint (SCM_UNPACK (program), 16, port);
  94. scm_putc ('>', port);
  95. }
  96. else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
  97. {
  98. /* twingliness */
  99. scm_puts ("#<partial-continuation ", port);
  100. scm_uintprint (SCM_UNPACK (program), 16, port);
  101. scm_putc ('>', port);
  102. }
  103. else if (scm_is_false (write_program) || print_error)
  104. {
  105. scm_puts ("#<program ", port);
  106. scm_uintprint (SCM_UNPACK (program), 16, port);
  107. scm_putc (' ', port);
  108. scm_uintprint ((uintptr_t) SCM_PROGRAM_CODE (program), 16, port);
  109. scm_putc ('>', port);
  110. }
  111. else
  112. {
  113. print_error = 1;
  114. scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
  115. print_error = 0;
  116. }
  117. }
  118. /*
  119. * Scheme interface
  120. */
  121. SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
  122. (SCM obj),
  123. "")
  124. #define FUNC_NAME s_scm_program_p
  125. {
  126. return scm_from_bool (SCM_PROGRAM_P (obj));
  127. }
  128. #undef FUNC_NAME
  129. SCM_DEFINE (scm_primitive_code_p, "primitive-code?", 1, 0, 0,
  130. (SCM code),
  131. "")
  132. #define FUNC_NAME s_scm_primitive_code_p
  133. {
  134. const uint32_t * ptr = (const uint32_t *) scm_to_uintptr_t (code);
  135. return scm_from_bool (scm_i_primitive_code_p (ptr));
  136. }
  137. #undef FUNC_NAME
  138. SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
  139. (SCM prim),
  140. "")
  141. #define FUNC_NAME s_scm_primitive_call_ip
  142. {
  143. uintptr_t ip;
  144. SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
  145. ip = scm_i_primitive_call_ip (prim);
  146. return ip ? scm_from_uintptr_t (ip) : SCM_BOOL_F;
  147. }
  148. #undef FUNC_NAME
  149. SCM_DEFINE (scm_primitive_code_name, "primitive-code-name", 1, 0, 0,
  150. (SCM code),
  151. "")
  152. #define FUNC_NAME s_scm_primitive_code_name
  153. {
  154. const uint32_t * ptr = (const uint32_t *) scm_to_uintptr_t (code);
  155. if (scm_i_primitive_code_p (ptr))
  156. return scm_i_primitive_name (ptr);
  157. return SCM_BOOL_F;
  158. }
  159. #undef FUNC_NAME
  160. SCM
  161. scm_find_source_for_addr (SCM ip)
  162. {
  163. static SCM source_for_addr = SCM_BOOL_F;
  164. if (scm_is_false (source_for_addr)) {
  165. if (!scm_module_system_booted_p)
  166. return SCM_BOOL_F;
  167. source_for_addr =
  168. scm_c_private_variable ("system vm program", "source-for-addr");
  169. }
  170. return scm_call_1 (scm_variable_ref (source_for_addr), ip);
  171. }
  172. SCM
  173. scm_program_address_range (SCM program)
  174. {
  175. static SCM program_address_range = SCM_BOOL_F;
  176. if (scm_is_false (program_address_range) && scm_module_system_booted_p)
  177. program_address_range =
  178. scm_c_private_variable ("system vm program", "program-address-range");
  179. return scm_call_1 (scm_variable_ref (program_address_range), program);
  180. }
  181. SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0,
  182. (SCM program),
  183. "")
  184. #define FUNC_NAME s_scm_program_num_free_variables
  185. {
  186. SCM_VALIDATE_PROGRAM (1, program);
  187. return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
  188. }
  189. #undef FUNC_NAME
  190. SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0,
  191. (SCM program, SCM i),
  192. "")
  193. #define FUNC_NAME s_scm_program_free_variable_ref
  194. {
  195. unsigned long idx;
  196. SCM_VALIDATE_PROGRAM (1, program);
  197. SCM_VALIDATE_ULONG_COPY (2, i, idx);
  198. if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
  199. SCM_OUT_OF_RANGE (2, i);
  200. return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
  201. }
  202. #undef FUNC_NAME
  203. SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, 0,
  204. (SCM program, SCM i, SCM x),
  205. "")
  206. #define FUNC_NAME s_scm_program_free_variable_set_x
  207. {
  208. unsigned long idx;
  209. SCM_VALIDATE_PROGRAM (1, program);
  210. SCM_VALIDATE_ULONG_COPY (2, i, idx);
  211. if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
  212. SCM_OUT_OF_RANGE (2, i);
  213. SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
  214. return SCM_UNSPECIFIED;
  215. }
  216. #undef FUNC_NAME
  217. /* It's hacky, but it manages to cover all of the non-keyword cases. */
  218. static int
  219. try_parse_arity (SCM program, int *req, int *opt, int *rest)
  220. {
  221. uint32_t *code = SCM_PROGRAM_CODE (program);
  222. uint32_t slots, min;
  223. if ((code[0] & 0xff) == scm_op_instrument_entry)
  224. code += 2;
  225. switch (code[0] & 0xff) {
  226. case scm_op_assert_nargs_ee:
  227. slots = code[0] >> 8;
  228. *req = slots - 1;
  229. *opt = 0;
  230. *rest = 0;
  231. return 1;
  232. case scm_op_assert_nargs_ee_locals:
  233. slots = (code[0] >> 8) & 0xfff;
  234. *req = slots - 1;
  235. *opt = 0;
  236. *rest = 0;
  237. return 1;
  238. case scm_op_assert_nargs_le:
  239. slots = code[0] >> 8;
  240. *req = 0;
  241. *opt = slots - 1;
  242. *rest = 0;
  243. return 1;
  244. case scm_op_bind_optionals:
  245. slots = code[0] >> 8;
  246. *req = 0;
  247. *opt = slots - 1;
  248. *rest = ((code[1] & 0xff) == scm_op_bind_rest);
  249. return 1;
  250. case scm_op_bind_rest:
  251. slots = code[0] >> 8;
  252. *req = 0;
  253. *opt = slots - 1;
  254. *rest = 1;
  255. return 1;
  256. case scm_op_assert_nargs_ge:
  257. min = code[0] >> 8;
  258. switch (code[1] & 0xff) {
  259. case scm_op_assert_nargs_le:
  260. slots = code[1] >> 8;
  261. *req = min - 1;
  262. *opt = slots - 1 - *req;
  263. *rest = 0;
  264. return 1;
  265. case scm_op_bind_optionals:
  266. slots = code[1] >> 8;
  267. *req = min - 1;
  268. *opt = slots - 1 - *req;
  269. *rest = ((code[2] & 0xff) == scm_op_bind_rest);
  270. return 1;
  271. case scm_op_bind_rest:
  272. slots = code[1] >> 8;
  273. *req = min - 1;
  274. *opt = slots - min;
  275. *rest = 1;
  276. return 1;
  277. case scm_op_shuffle_down:
  278. case scm_op_abort:
  279. *req = min - 1;
  280. *opt = 0;
  281. *rest = 1;
  282. return 1;
  283. default:
  284. return 0;
  285. }
  286. case scm_op_continuation_call:
  287. case scm_op_compose_continuation:
  288. case scm_op_shuffle_down:
  289. *req = 0;
  290. *opt = 0;
  291. *rest = 1;
  292. return 1;
  293. default:
  294. return 0;
  295. }
  296. }
  297. int
  298. scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
  299. {
  300. static SCM program_minimum_arity = SCM_BOOL_F;
  301. SCM l;
  302. if (try_parse_arity (program, req, opt, rest))
  303. return 1;
  304. if (scm_is_false (program_minimum_arity) && scm_module_system_booted_p)
  305. program_minimum_arity =
  306. scm_c_private_variable ("system vm program", "program-minimum-arity");
  307. l = scm_call_1 (scm_variable_ref (program_minimum_arity), program);
  308. if (scm_is_false (l))
  309. return 0;
  310. *req = scm_to_int (scm_car (l));
  311. *opt = scm_to_int (scm_cadr (l));
  312. *rest = scm_is_true (scm_caddr (l));
  313. return 1;
  314. }
  315. void
  316. scm_bootstrap_programs (void)
  317. {
  318. scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
  319. "scm_init_programs",
  320. (scm_t_extension_init_func)scm_init_programs, NULL);
  321. }
  322. void
  323. scm_init_programs (void)
  324. {
  325. #ifndef SCM_MAGIC_SNARFER
  326. #include "programs.x"
  327. #endif
  328. }