generating the tedious code

generate-c-star-d.rkt

@@ -0,0 +1,72 @@
+#lang racket
+
+(provide make-c*r names)
+
+;; A little helper to generate the tedious code for the c*r functions.
+
+(define (make-c*r (n 4))
+  (define template #<<EOF
+installPrimitiveProcedure(
+  ~s,
+   1,
+   function(M) {
+       var x = M.e[M.e.length-1];
+       if (isPair(x)&&~a) {
+           return x.~a;
+       } else {
+           raiseArgumentTypeError(M, ~s, ~s, 0, x);
+       }
+   });
+
+EOF
+
+    )
+  (for/list ([desc (combinations n)])
+    (format template
+            (string-append "c" desc "r")
+            (test desc)
+            (accessor desc)
+            (string-append "c" desc "r")
+            (string-append "c" desc "rable value"))))
+
+
+(define (names (n 4))
+  (for/list ([desc (combinations n)])
+    (string->symbol (string-append "c" desc "r"))))
+
+
+
+
+(define (combinations n)
+  (let loop ([n n])
+    (cond
+      [(= n 2)
+       (list "aa" "ad" "da" "dd")]
+      [else
+       (define sub-answers (loop (sub1 n)))
+       (append sub-answers
+               (map (lambda (x) (string-append x "a")) sub-answers)
+               (map (lambda (x) (string-append x "d")) sub-answers))])))
+ 
+(define (accessor s)
+  (string-join 
+   (reverse (for/list ([ch s])
+              (case ch
+                [(#\a) "first"]
+                [(#\d) "rest"])))
+   "."))
+
+(define (test s)
+  (string-join (for/list ([i (in-range 1 (string-length s))])
+                 (let ([s (substring s 
+                                     (- (string-length s) i)
+                        (string-length s))])
+                   (format "isPair(x.~a)" 
+                           (string-join 
+                            (reverse (for/list ([ch s])
+                          (case ch
+                            [(#\a) "first"]
+                            [(#\d) "rest"])))
+                            "."))))
+               "&&"))
+