pairs.h 8.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263
  1. #ifndef SCM_PAIRS_H
  2. #define SCM_PAIRS_H
  3. /* Copyright 1995-1996,2000-2001,2004,2006,2008-2010,2012,2018
  4. Free Software Foundation, Inc.
  5. This file is part of Guile.
  6. Guile is free software: you can redistribute it and/or modify it
  7. under the terms of the GNU Lesser General Public License as published
  8. by the Free Software Foundation, either version 3 of the License, or
  9. (at your option) any later version.
  10. Guile is distributed in the hope that it will be useful, but WITHOUT
  11. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  13. License for more details.
  14. You should have received a copy of the GNU Lesser General Public
  15. License along with Guile. If not, see
  16. <https://www.gnu.org/licenses/>. */
  17. #include "libguile/error.h"
  18. #include "libguile/gc.h"
  19. #include "libguile/inline.h"
  20. /*
  21. * Use scm_is_null_and_not_nil if it's important (for correctness)
  22. * that #nil must NOT be considered null.
  23. */
  24. #define scm_is_null_and_not_nil(x) (scm_is_eq ((x), SCM_EOL))
  25. /*
  26. * Use scm_is_null_assume_not_nil if
  27. #nil will never be tested,
  28. * for increased efficiency.
  29. */
  30. #define scm_is_null_assume_not_nil(x) (scm_is_eq ((x), SCM_EOL))
  31. /*
  32. * See the comments preceeding the definitions of SCM_BOOL_F and
  33. * SCM_MATCHES_BITS_IN_COMMON in scm.h for more information on how the
  34. * following macro works.
  35. */
  36. #define scm_is_null_or_nil(x) \
  37. (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_ELISP_NIL, SCM_EOL))
  38. /* Older spellings for these null, nil, and pair predicates. */
  39. #define SCM_NILP(x) (scm_is_eq ((x), SCM_ELISP_NIL))
  40. #define SCM_NULL_OR_NIL_P(x) (scm_is_null_or_nil (x))
  41. #define SCM_NULLP(x) (scm_is_null (x))
  42. #define SCM_NNULLP(x) (!scm_is_null (x))
  43. #define SCM_CONSP(x) (scm_is_pair (x))
  44. #define SCM_NCONSP(x) (!SCM_CONSP (x))
  45. /* #nil is null. */
  46. #define scm_is_null(x) (scm_is_null_or_nil(x))
  47. #define SCM_CAR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (x)))
  48. #define SCM_CDR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (x)))
  49. #define SCM_SETCAR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_0 ((x), (v))))
  50. #define SCM_SETCDR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_1 ((x), (v))))
  51. #define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ))
  52. #define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ))
  53. #define SCM_CADR(OBJ) SCM_CAR (SCM_CDR (OBJ))
  54. #define SCM_CDDR(OBJ) SCM_CDR (SCM_CDR (OBJ))
  55. #define SCM_CAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (OBJ)))
  56. #define SCM_CDAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (OBJ)))
  57. #define SCM_CADAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (OBJ)))
  58. #define SCM_CDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (OBJ)))
  59. #define SCM_CAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (OBJ)))
  60. #define SCM_CDADR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (OBJ)))
  61. #define SCM_CADDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (OBJ)))
  62. #define SCM_CDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (OBJ)))
  63. #define SCM_CAAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ))))
  64. #define SCM_CDAAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ))))
  65. #define SCM_CADAAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ))))
  66. #define SCM_CDDAAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ))))
  67. #define SCM_CAADAR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ))))
  68. #define SCM_CDADAR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ))))
  69. #define SCM_CADDAR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ))))
  70. #define SCM_CDDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ))))
  71. #define SCM_CAAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ))))
  72. #define SCM_CDAADR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ))))
  73. #define SCM_CADADR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ))))
  74. #define SCM_CDDADR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ))))
  75. #define SCM_CAADDR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ))))
  76. #define SCM_CDADDR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ))))
  77. #define SCM_CADDDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ))))
  78. #define SCM_CDDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ))))
  79. #define SCM_VALIDATE_NULL(pos, scm) \
  80. SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_null, "empty list")
  81. #define SCM_VALIDATE_NULL_OR_NIL(pos, scm) \
  82. SCM_MAKE_VALIDATE_MSG (pos, scm, NULL_OR_NIL_P, "empty list")
  83. #define SCM_VALIDATE_CONS(pos, scm) \
  84. SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_pair, "pair")
  85. #if (SCM_DEBUG_PAIR_ACCESSES == 1)
  86. # define SCM_VALIDATE_PAIR(cell, expr) \
  87. ((!scm_is_pair (cell) ? scm_error_pair_access (cell), 0 : 0), (expr))
  88. #else
  89. # define SCM_VALIDATE_PAIR(cell, expr) (expr)
  90. #endif
  91. #ifdef BUILDING_LIBGUILE
  92. #define SCM_VALIDATE_MUTABLE_PAIR(pos, scm) \
  93. SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_mutable_pair, "mutable pair")
  94. #endif /* BUILDING_LIBGUILE */
  95. #define SCM_VALIDATE_NULLORCONS(pos, env) \
  96. do { \
  97. SCM_ASSERT (scm_is_null (env) || scm_is_pair (env), env, pos, FUNC_NAME); \
  98. } while (0)
  99. #if (SCM_DEBUG_PAIR_ACCESSES == 1)
  100. SCM_API void scm_error_pair_access (SCM);
  101. #endif
  102. SCM_INLINE int scm_is_pair (SCM x);
  103. SCM_INLINE SCM scm_cons (SCM x, SCM y);
  104. SCM_INLINE SCM scm_car (SCM x);
  105. SCM_INLINE SCM scm_cdr (SCM x);
  106. #if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
  107. /* Return a newly allocated pair whose car is @var{x} and whose cdr is
  108. @var{y}. The pair is guaranteed to be different (in the sense of
  109. @code{eq?}) from every previously existing object. */
  110. SCM_INLINE_IMPLEMENTATION SCM
  111. scm_cons (SCM x, SCM y)
  112. {
  113. return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));
  114. }
  115. SCM_INLINE_IMPLEMENTATION int
  116. scm_is_pair (SCM x)
  117. {
  118. /* The following "workaround_for_gcc_295" avoids bad code generated by
  119. i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least).
  120. Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
  121. the fetch of the tag word from x is done before confirming it's a
  122. non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a
  123. immediate. This was seen to afflict scm_srfi1_split_at and something
  124. deep in the bowels of ceval(). In both cases segvs resulted from
  125. deferencing a random immediate value. srfi-1.test exposes the problem
  126. through a short list, the immediate being SCM_EOL in that case.
  127. Something in syntax.test exposed the ceval() problem.
  128. Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the
  129. problem, without even using that variable. The "w=w" is just to
  130. prevent a warning about it being unused.
  131. */
  132. #if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95
  133. volatile SCM workaround_for_gcc_295 = x;
  134. workaround_for_gcc_295 = workaround_for_gcc_295;
  135. #endif
  136. return SCM_I_CONSP (x);
  137. }
  138. SCM_INLINE_IMPLEMENTATION SCM
  139. scm_car (SCM x)
  140. {
  141. if (SCM_UNLIKELY (!scm_is_pair (x)))
  142. scm_wrong_type_arg_msg ("car", 0, x, "pair");
  143. return SCM_CAR (x);
  144. }
  145. SCM_INLINE_IMPLEMENTATION SCM
  146. scm_cdr (SCM x)
  147. {
  148. if (SCM_UNLIKELY (!scm_is_pair (x)))
  149. scm_wrong_type_arg_msg ("cdr", 0, x, "pair");
  150. return SCM_CDR (x);
  151. }
  152. #endif
  153. #ifdef BUILDING_LIBGUILE
  154. #ifndef HAVE_GC_IS_HEAP_PTR
  155. static int
  156. GC_is_heap_ptr (void *ptr)
  157. {
  158. return GC_base (ptr) != NULL;
  159. }
  160. #endif
  161. static inline int
  162. scm_is_mutable_pair (SCM x)
  163. {
  164. /* Guile embeds literal pairs into compiled object files. It's not
  165. valid Scheme to mutate literal values. Two practical reasons to
  166. enforce this restriction are to allow literals to share share
  167. structure (pairs) with other literals in the compilation unit, and
  168. to allow literals containing immediates to be allocated in the
  169. read-only, shareable section of the file. Attempting to mutate a
  170. pair in the read-only section would cause a segmentation fault, so
  171. to avoid that, we really do need to enforce the restriction. */
  172. return scm_is_pair (x) && GC_is_heap_ptr (SCM2PTR (x));
  173. }
  174. #endif /* BUILDING_LIBGUILE */
  175. SCM_API SCM scm_cons2 (SCM w, SCM x, SCM y);
  176. SCM_API SCM scm_pair_p (SCM x);
  177. SCM_API SCM scm_set_car_x (SCM pair, SCM value);
  178. SCM_API SCM scm_set_cdr_x (SCM pair, SCM value);
  179. SCM_API SCM scm_cddr (SCM x);
  180. SCM_API SCM scm_cdar (SCM x);
  181. SCM_API SCM scm_cadr (SCM x);
  182. SCM_API SCM scm_caar (SCM x);
  183. SCM_API SCM scm_cdddr (SCM x);
  184. SCM_API SCM scm_cddar (SCM x);
  185. SCM_API SCM scm_cdadr (SCM x);
  186. SCM_API SCM scm_cdaar (SCM x);
  187. SCM_API SCM scm_caddr (SCM x);
  188. SCM_API SCM scm_cadar (SCM x);
  189. SCM_API SCM scm_caadr (SCM x);
  190. SCM_API SCM scm_caaar (SCM x);
  191. SCM_API SCM scm_cddddr (SCM x);
  192. SCM_API SCM scm_cdddar (SCM x);
  193. SCM_API SCM scm_cddadr (SCM x);
  194. SCM_API SCM scm_cddaar (SCM x);
  195. SCM_API SCM scm_cdaddr (SCM x);
  196. SCM_API SCM scm_cdadar (SCM x);
  197. SCM_API SCM scm_cdaadr (SCM x);
  198. SCM_API SCM scm_cdaaar (SCM x);
  199. SCM_API SCM scm_cadddr (SCM x);
  200. SCM_API SCM scm_caddar (SCM x);
  201. SCM_API SCM scm_cadadr (SCM x);
  202. SCM_API SCM scm_cadaar (SCM x);
  203. SCM_API SCM scm_caaddr (SCM x);
  204. SCM_API SCM scm_caadar (SCM x);
  205. SCM_API SCM scm_caaadr (SCM x);
  206. SCM_API SCM scm_caaaar (SCM x);
  207. SCM_INTERNAL void scm_init_pairs (void);
  208. #endif /* SCM_PAIRS_H */