pairs.c 8.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343
  1. /* Copyright 1995-1996,2000-2001,2004-2006,2008-2013,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. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include <verify.h>
  19. #include "boolean.h"
  20. #include "gsubr.h"
  21. #include "pairs.h"
  22. /* {Pairs}
  23. */
  24. /*
  25. * This compile-time test verifies the properties needed for the
  26. * efficient test macro scm_is_null_or_nil defined in pairs.h,
  27. * which is defined in terms of the SCM_MATCHES_BITS_IN_COMMON macro.
  28. *
  29. * See the comments preceeding the definitions of SCM_BOOL_F and
  30. * SCM_MATCHES_BITS_IN_COMMON in scm.h for more information.
  31. */
  32. verify (SCM_BITS_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
  33. (SCM_ELISP_NIL_BITS, SCM_EOL_BITS));
  34. #if (SCM_DEBUG_PAIR_ACCESSES == 1)
  35. #include "ports.h"
  36. #include "strings.h"
  37. void scm_error_pair_access (SCM non_pair)
  38. {
  39. static unsigned int running = 0;
  40. SCM message = scm_from_utf8_string ("Non-pair accessed with SCM_C[AD]R: `~S'\n");
  41. if (!running)
  42. {
  43. running = 1;
  44. scm_simple_format (scm_current_error_port (),
  45. message, scm_list_1 (non_pair));
  46. abort ();
  47. }
  48. }
  49. #endif
  50. SCM
  51. scm_cons2 (SCM w, SCM x, SCM y)
  52. {
  53. return scm_cons (w, scm_cons (x, y));
  54. }
  55. SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0,
  56. (SCM x),
  57. "Return @code{#t} if @var{x} is a pair; otherwise return\n"
  58. "@code{#f}.")
  59. #define FUNC_NAME s_scm_pair_p
  60. {
  61. return scm_from_bool (scm_is_pair (x));
  62. }
  63. #undef FUNC_NAME
  64. SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0,
  65. (SCM pair, SCM value),
  66. "Stores @var{value} in the car field of @var{pair}. The value returned\n"
  67. "by @code{set-car!} is unspecified.")
  68. #define FUNC_NAME s_scm_set_car_x
  69. {
  70. SCM_VALIDATE_MUTABLE_PAIR (1, pair);
  71. SCM_SETCAR (pair, value);
  72. return SCM_UNSPECIFIED;
  73. }
  74. #undef FUNC_NAME
  75. SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0,
  76. (SCM pair, SCM value),
  77. "Stores @var{value} in the cdr field of @var{pair}. The value returned\n"
  78. "by @code{set-cdr!} is unspecified.")
  79. #define FUNC_NAME s_scm_set_cdr_x
  80. {
  81. SCM_VALIDATE_MUTABLE_PAIR (1, pair);
  82. SCM_SETCDR (pair, value);
  83. return SCM_UNSPECIFIED;
  84. }
  85. #undef FUNC_NAME
  86. /* Every cxr-pattern is made up of pairs of bits, starting with the two least
  87. * significant bits. If in a pair of bits the least significant of the two
  88. * bits is 0, this means CDR, otherwise CAR. The most significant bits of the
  89. * two bits is only needed to indicate when cxr-ing is ready. This is the
  90. * case, when all remaining pairs of bits equal 00. */
  91. /* The compiler should unroll this. */
  92. #define CHASE_PAIRS(tree, FUNC_NAME, pattern) \
  93. uint32_t pattern_var = pattern; \
  94. do \
  95. { \
  96. if (!scm_is_pair (tree)) \
  97. scm_wrong_type_arg_msg (FUNC_NAME, 0, tree, "pair"); \
  98. tree = (pattern_var & 1) ? SCM_CAR (tree) : SCM_CDR (tree); \
  99. pattern_var >>= 2; \
  100. } \
  101. while (pattern_var); \
  102. return tree
  103. SCM_DEFINE (scm_cddr, "cddr", 1, 0, 0, (SCM x), "")
  104. #define FUNC_NAME s_scm_cddr
  105. {
  106. CHASE_PAIRS (x, "cddr", 0x0a); /* 00001010 */
  107. }
  108. #undef FUNC_NAME
  109. SCM_DEFINE (scm_cdar, "cdar", 1, 0, 0, (SCM x), "")
  110. #define FUNC_NAME s_scm_cdar
  111. {
  112. CHASE_PAIRS (x, "cdar", 0x0b); /* 00001011 */
  113. }
  114. #undef FUNC_NAME
  115. SCM_DEFINE (scm_cadr, "cadr", 1, 0, 0, (SCM x), "")
  116. #define FUNC_NAME s_scm_cadr
  117. {
  118. CHASE_PAIRS (x, "cadr", 0x0e); /* 00001110 */
  119. }
  120. #undef FUNC_NAME
  121. SCM_DEFINE (scm_caar, "caar", 1, 0, 0, (SCM x), "")
  122. #define FUNC_NAME s_scm_caar
  123. {
  124. CHASE_PAIRS (x, "caar", 0x0f); /* 00001111 */
  125. }
  126. #undef FUNC_NAME
  127. SCM_DEFINE (scm_cdddr, "cdddr", 1, 0, 0, (SCM x), "")
  128. #define FUNC_NAME s_scm_cdddr
  129. {
  130. CHASE_PAIRS (x, "cdddr", 0x2a); /* 00101010 */
  131. }
  132. #undef FUNC_NAME
  133. SCM_DEFINE (scm_cddar, "cddar", 1, 0, 0, (SCM x), "")
  134. #define FUNC_NAME s_scm_cddar
  135. {
  136. CHASE_PAIRS (x, "cddar", 0x2b); /* 00101011 */
  137. }
  138. #undef FUNC_NAME
  139. SCM_DEFINE (scm_cdadr, "cdadr", 1, 0, 0, (SCM x), "")
  140. #define FUNC_NAME s_scm_cdadr
  141. {
  142. CHASE_PAIRS (x, "cdadr", 0x2e); /* 00101110 */
  143. }
  144. #undef FUNC_NAME
  145. SCM_DEFINE (scm_cdaar, "cdaar", 1, 0, 0, (SCM x), "")
  146. #define FUNC_NAME s_scm_cdaar
  147. {
  148. CHASE_PAIRS (x, "cdaar", 0x2f); /* 00101111 */
  149. }
  150. #undef FUNC_NAME
  151. SCM_DEFINE (scm_caddr, "caddr", 1, 0, 0, (SCM x), "")
  152. #define FUNC_NAME s_scm_caddr
  153. {
  154. CHASE_PAIRS (x, "caddr", 0x3a); /* 00111010 */
  155. }
  156. #undef FUNC_NAME
  157. SCM_DEFINE (scm_cadar, "cadar", 1, 0, 0, (SCM x), "")
  158. #define FUNC_NAME s_scm_cadar
  159. {
  160. CHASE_PAIRS (x, "cadar", 0x3b); /* 00111011 */
  161. }
  162. #undef FUNC_NAME
  163. SCM_DEFINE (scm_caadr, "caadr", 1, 0, 0, (SCM x), "")
  164. #define FUNC_NAME s_scm_caadr
  165. {
  166. CHASE_PAIRS (x, "caadr", 0x3e); /* 00111110 */
  167. }
  168. #undef FUNC_NAME
  169. SCM_DEFINE (scm_caaar, "caaar", 1, 0, 0, (SCM x), "")
  170. #define FUNC_NAME s_scm_caaar
  171. {
  172. CHASE_PAIRS (x, "caaar", 0x3f); /* 00111111 */
  173. }
  174. #undef FUNC_NAME
  175. SCM_DEFINE (scm_cddddr, "cddddr", 1, 0, 0, (SCM x), "")
  176. #define FUNC_NAME s_scm_cddddr
  177. {
  178. CHASE_PAIRS (x, "cddddr", 0xaa); /* 10101010 */
  179. }
  180. #undef FUNC_NAME
  181. SCM_DEFINE (scm_cdddar, "cdddar", 1, 0, 0, (SCM x), "")
  182. #define FUNC_NAME s_scm_cdddar
  183. {
  184. CHASE_PAIRS (x, "cdddar", 0xab); /* 10101011 */
  185. }
  186. #undef FUNC_NAME
  187. SCM_DEFINE (scm_cddadr, "cddadr", 1, 0, 0, (SCM x), "")
  188. #define FUNC_NAME s_scm_cddadr
  189. {
  190. CHASE_PAIRS (x, "cddadr", 0xae); /* 10101110 */
  191. }
  192. #undef FUNC_NAME
  193. SCM_DEFINE (scm_cddaar, "cddaar", 1, 0, 0, (SCM x), "")
  194. #define FUNC_NAME s_scm_cddaar
  195. {
  196. CHASE_PAIRS (x, "cddaar", 0xaf); /* 10101111 */
  197. }
  198. #undef FUNC_NAME
  199. SCM_DEFINE (scm_cdaddr, "cdaddr", 1, 0, 0, (SCM x), "")
  200. #define FUNC_NAME s_scm_cdaddr
  201. {
  202. CHASE_PAIRS (x, "cdaddr", 0xba); /* 10111010 */
  203. }
  204. #undef FUNC_NAME
  205. SCM_DEFINE (scm_cdadar, "cdadar", 1, 0, 0, (SCM x), "")
  206. #define FUNC_NAME s_scm_cdadar
  207. {
  208. CHASE_PAIRS (x, "cdadar", 0xbb); /* 10111011 */
  209. }
  210. #undef FUNC_NAME
  211. SCM_DEFINE (scm_cdaadr, "cdaadr", 1, 0, 0, (SCM x), "")
  212. #define FUNC_NAME s_scm_cdaadr
  213. {
  214. CHASE_PAIRS (x, "cdaadr", 0xbe); /* 10111110 */
  215. }
  216. #undef FUNC_NAME
  217. SCM_DEFINE (scm_cdaaar, "cdaaar", 1, 0, 0, (SCM x), "")
  218. #define FUNC_NAME s_scm_cdaaar
  219. {
  220. CHASE_PAIRS (x, "cdaaar", 0xbf); /* 10111111 */
  221. }
  222. #undef FUNC_NAME
  223. SCM_DEFINE (scm_cadddr, "cadddr", 1, 0, 0, (SCM x), "")
  224. #define FUNC_NAME s_scm_cadddr
  225. {
  226. CHASE_PAIRS (x, "cadddr", 0xea); /* 11101010 */
  227. }
  228. #undef FUNC_NAME
  229. SCM_DEFINE (scm_caddar, "caddar", 1, 0, 0, (SCM x), "")
  230. #define FUNC_NAME s_scm_caddar
  231. {
  232. CHASE_PAIRS (x, "caddar", 0xeb); /* 11101011 */
  233. }
  234. #undef FUNC_NAME
  235. SCM_DEFINE (scm_cadadr, "cadadr", 1, 0, 0, (SCM x), "")
  236. #define FUNC_NAME s_scm_cadadr
  237. {
  238. CHASE_PAIRS (x, "cadadr", 0xee); /* 11101110 */
  239. }
  240. #undef FUNC_NAME
  241. SCM_DEFINE (scm_cadaar, "cadaar", 1, 0, 0, (SCM x), "")
  242. #define FUNC_NAME s_scm_cadaar
  243. {
  244. CHASE_PAIRS (x, "cadaar", 0xef); /* 11101111 */
  245. }
  246. #undef FUNC_NAME
  247. SCM_DEFINE (scm_caaddr, "caaddr", 1, 0, 0, (SCM x), "")
  248. #define FUNC_NAME s_scm_caaddr
  249. {
  250. CHASE_PAIRS (x, "caaddr", 0xfa); /* 11111010 */
  251. }
  252. #undef FUNC_NAME
  253. SCM_DEFINE (scm_caadar, "caadar", 1, 0, 0, (SCM x), "")
  254. #define FUNC_NAME s_scm_caadar
  255. {
  256. CHASE_PAIRS (x, "caadar", 0xfb); /* 11111011 */
  257. }
  258. #undef FUNC_NAME
  259. SCM_DEFINE (scm_caaadr, "caaadr", 1, 0, 0, (SCM x), "")
  260. #define FUNC_NAME s_scm_caaadr
  261. {
  262. CHASE_PAIRS (x, "caaadr", 0xfe); /* 11111110 */
  263. }
  264. #undef FUNC_NAME
  265. SCM_DEFINE (scm_caaaar, "caaaar", 1, 0, 0, (SCM x), "")
  266. #define FUNC_NAME s_scm_caaaar
  267. {
  268. CHASE_PAIRS (x, "caaaar", 0xff); /* 11111111 */
  269. }
  270. #undef FUNC_NAME
  271. void
  272. scm_init_pairs ()
  273. {
  274. #include "pairs.x"
  275. scm_c_define_gsubr ("cons", 2, 0, 0, scm_cons);
  276. scm_c_define_gsubr ("car", 1, 0, 0, scm_car);
  277. scm_c_define_gsubr ("cdr", 1, 0, 0, scm_cdr);
  278. }