~ chicken-core (chicken-5) f11bdbcc9ac7fa85276dac5b622852b87d2e7c38

commit f11bdbcc9ac7fa85276dac5b622852b87d2e7c38
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jul 16 01:17:18 2010 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jul 16 01:17:18 2010 +0200

    added compiler re-writes and C implementations of safe caar and cdar

diff --git a/c-platform.scm b/c-platform.scm
index a1d0c5f7..f992f05c 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -566,6 +566,8 @@
 (rewrite 'cdddar 2 1 "C_u_i_cdddar" #f)
 (rewrite 'cddddr 2 1 "C_u_i_cddddr" #f)
 
+(rewrite 'caar 2 1 "C_i_caar" #t)
+(rewrite 'cdar 2 1 "C_i_cdar" #t)
 (rewrite 'cddr 2 1 "C_i_cddr" #t)
 (rewrite 'cdddr 2 1 "C_i_cdddr" #t)
 (rewrite 'cddddr 2 1 "C_i_cddddr" #t)
diff --git a/chicken.h b/chicken.h
index 6f673062..7e698629 100644
--- a/chicken.h
+++ b/chicken.h
@@ -920,6 +920,8 @@ extern double round(double);
 extern double trunc(double);
 # endif
 #else
+/* provide this file and define C_PROVIDE_LIBC_STUBS if you want to use
+   your own libc-replacements or -wrappers */
 # include "chicken-libc-stubs.h"
 #endif
 
@@ -1722,7 +1724,9 @@ C_fctexport C_word C_fcall C_i_negativep(C_word x) C_regparm;
 C_fctexport C_word C_fcall C_u_i_negativep(C_word x) C_regparm;
 C_fctexport C_word C_fcall C_i_car(C_word x) C_regparm;
 C_fctexport C_word C_fcall C_i_cdr(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_caar(C_word x) C_regparm;
 C_fctexport C_word C_fcall C_i_cadr(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_cdar(C_word x) C_regparm;
 C_fctexport C_word C_fcall C_i_cddr(C_word x) C_regparm;
 C_fctexport C_word C_fcall C_i_caddr(C_word x) C_regparm;
 C_fctexport C_word C_fcall C_i_cdddr(C_word x) C_regparm;
diff --git a/runtime.c b/runtime.c
index 4de9bdd2..cd17c989 100644
--- a/runtime.c
+++ b/runtime.c
@@ -3606,17 +3606,7 @@ C_regparm void C_fcall C_trace(C_char *name)
 /* DEPRECATED: throw out at some stage: */
 C_regparm C_word C_fcall C_emit_trace_info(C_word x, C_word y, C_word t)
 {
-  if(trace_buffer_top >= trace_buffer_limit) {
-    trace_buffer_top = trace_buffer;
-    trace_buffer_full = 1;
-  }
-
-  trace_buffer_top->raw = "<eval>";
-  trace_buffer_top->cooked1 = x;
-  trace_buffer_top->cooked2 = y;
-  trace_buffer_top->thread = t;
-  ++trace_buffer_top;
-  return x;
+  return C_emit_trace_info2("<eval>", x, y, t);
 }
 
 
@@ -4647,6 +4637,21 @@ C_regparm C_word C_fcall C_i_cdr(C_word x)
 }
 
 
+C_regparm C_word C_fcall C_i_caar(C_word x)
+{
+  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
+  bad:
+    barf(C_BAD_ARGUMENT_TYPE_ERROR, "caar", x);
+  }
+
+  x = C_u_i_car(x);
+
+  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+
+  return C_u_i_car(x);
+}
+
+
 C_regparm C_word C_fcall C_i_cadr(C_word x)
 {
   if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
@@ -4655,12 +4660,28 @@ C_regparm C_word C_fcall C_i_cadr(C_word x)
   }
 
   x = C_u_i_cdr(x);
+
   if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
 
   return C_u_i_car(x);
 }
 
 
+C_regparm C_word C_fcall C_i_cdar(C_word x)
+{
+  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
+  bad:
+    barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdar", x);
+  }
+
+  x = C_u_i_car(x);
+
+  if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+
+  return C_u_i_cdr(x);
+}
+
+
 C_regparm C_word C_fcall C_i_cddr(C_word x)
 {
   if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {