From 3d34c22b97fecb831e6e93b3e3f6a53325a3e518 Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Mon, 20 Feb 2012 16:49:37 -0500
Subject: [PATCH] trying to fix all the silly c...r functions

---
 compiler/kernel-primitives.rkt                |  34 +-
 generate-c-star-d.rkt                         |  23 +-
 .../runtime-src/baselib-primitives.js         | 441 +++++++++++-------
 lang/kernel.rkt                               |  26 +-
 4 files changed, 329 insertions(+), 195 deletions(-)

diff --git a/compiler/kernel-primitives.rkt b/compiler/kernel-primitives.rkt
index 490cc25..0eedcaa 100644
--- a/compiler/kernel-primitives.rkt
+++ b/compiler/kernel-primitives.rkt
@@ -30,25 +30,39 @@
                                     'cons
                                     'car
                                     'cdr
-				    'caar
-				    'cadr
+
+                                    
+                                    'caar
                                     'cdar
+                                    'cadr
                                     'cddr
                                     'caaar
-                                    'caadr
-                                    'cadar
-				    'caddr
                                     'cdaar
-                                    'cdadr
+                                    'cadar
                                     'cddar
+                                    'caadr
+                                    'cdadr
+                                    'caddr
                                     'cdddr
                                     'caaaar
-                                    'caaadr
+                                    'cdaaar
+                                    'cadaar
+                                    'cddaar
                                     'caadar
-                                    'caaddr
-				    'cadddr
+                                    'cdadar
                                     'caddar
-                                    'list
+                                    'cdddar
+                                    'caaadr
+                                    'cdaadr
+                                    'cadadr
+                                    'cddadr
+                                    'caaddr
+                                    'cdaddr
+                                    'cadddr
+                                    'cddddr
+
+                                    
+				    'list
                                     'list?
                                     'list*
                                     'list->vector
diff --git a/generate-c-star-d.rkt b/generate-c-star-d.rkt
index 4a39731..d5e3bb8 100644
--- a/generate-c-star-d.rkt
+++ b/generate-c-star-d.rkt
@@ -7,7 +7,7 @@
 (define (make-c*r (n 4))
   (define template #<<EOF
 installPrimitiveProcedure(
-  ~s,
+  '~a',
    1,
    function(M) {
        var x = M.e[M.e.length-1];
@@ -38,15 +38,18 @@ EOF
 
 
 (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 (helper n)
+    (let loop ([n n])
+      (cond
+        [(= n 1)
+         (list "a" "d")]
+        [else
+         (define sub-answers (loop (sub1 n)))
+         (append (map (lambda (x) (string-append x "a")) sub-answers)
+                 (map (lambda (x) (string-append x "d")) sub-answers))])))
+  (apply append (for/list ([n (in-range 2 (add1 n))])
+                  (helper n))))
+  
  
 (define (accessor s)
   (string-join 
diff --git a/js-assembler/runtime-src/baselib-primitives.js b/js-assembler/runtime-src/baselib-primitives.js
index e880d6d..9a1a2df 100644
--- a/js-assembler/runtime-src/baselib-primitives.js
+++ b/js-assembler/runtime-src/baselib-primitives.js
@@ -96,97 +96,6 @@
     );
     var checkRational = baselib.check.checkRational;
     var checkPair = baselib.check.checkPair;
-    var checkCaarPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.first);
-	},
-	'caarable value');
-    var checkCdarPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.first);
-	},
-	'cdarable value');
-    var checkCadrPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.rest);
-	},
-	'cadrable value');
-    var checkCddrPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.rest);
-	},
-	'cddrable value');
-    var checkCaddrPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.rest) && isPair(x.rest.rest);
-	},
-	'caddrable value');
-   var checkCaaarPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.first) && isPair(x.first.first);
-	},
-       'caaarable value'); 
-   var checkCdaarPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.first) && isPair(x.first.first);
-	},
-       'cdaarable value'); 
-   var checkCddarPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.first) && isPair(x.first.rest);
-	},
-       'cddarable value'); 
-   var checkCadarPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.first) && isPair(x.first.rest);
-	},
-       'cadarable value'); 
-   var checkCaaaarPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.first) && isPair(x.first.first) && isPair(x.first.first.first);
-	},
-	'caaaarable value');
-   var checkCaadarPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.first) && isPair(x.first.rest) && isPair(x.first.rest.first);
-	},
-	'caadarable value');
-   var checkCaaddrPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.rest) && isPair(x.rest.rest) && isPair(x.rest.rest.first);
-	},
-	'caaddrable value');
-   var checkCaaadrPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.rest) && isPair(x.rest.first) && isPair(x.rest.first.first);
-	},
-	'caaadrable value');
-   var checkCadddrPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.rest) && isPair(x.rest.rest) && isPair(x.rest.rest.rest);
-	},
-	'cadddrable value');
-    var checkCaadrPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.rest) && isPair(x.rest.first);
-	},
-	'caadrable value');
-    var checkCdddrPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.rest) && isPair(x.rest.rest);
-	},
-	'cdddrable value');
-    var checkCdadrPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.rest) && isPair(x.rest.first);
-	},
-	'cdadrable value');
-    var checkCaddarPair = baselib.check.makeCheckArgumentType(
-	function(x) {
-	    return isPair(x) && isPair(x.first) && isPair(x.first.rest) && isPair(x.first.rest.rest);
-	},
-	'caddarable value');
-
     var checkList = baselib.check.checkList;
     var checkListofChars = baselib.check.makeCheckListofArgumentType(isChar, 'character');
     var checkListofPairs = baselib.check.makeCheckListofArgumentType(isPair, 'pair');
@@ -696,132 +605,330 @@
             var firstArg = checkPair(M, 'cdr', 0);
             return firstArg.rest;
         });
+
+    //////////////////////////////////////////////////////////////////////
+    //////////////////////////////////////////////////////////////////////
+    // The code from this point up to the end of the c**r functions
+    // is autogenerated by whalesong/generate-c-star-d.rkt.
+    //
+    // Don't modify this code manually: rather, edit the generator and
+    // inject the content back in here.
+    // Too bad we don't have macros in JavaScript...
+
     installPrimitiveProcedure(
         'caar',
         1,
-        function (M) {
-            var firstArg = checkCaarPair(M, 'caar', 0);
-            return firstArg.first.first;
-        });
-    installPrimitiveProcedure(
-        'cadr',
-        1,
-        function (M) {
-            var firstArg = checkCadrPair(M, 'cadr', 0);
-            return firstArg.rest.first;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)) {
+                return x.first.first;
+            } else {
+                raiseArgumentTypeError(M, "caar", "caarable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
         'cdar',
         1,
-        function (M) {
-            var firstArg = checkCdarPair(M, 'cdar', 0);
-            return firstArg.first.rest;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)) {
+                return x.first.rest;
+            } else {
+                raiseArgumentTypeError(M, "cdar", "cdarable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'cadr',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)) {
+                return x.rest.first;
+            } else {
+                raiseArgumentTypeError(M, "cadr", "cadrable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
         'cddr',
         1,
-        function (M) {
-            var firstArg = checkCddrPair(M, 'cddr', 0);
-            return firstArg.rest.rest;
-        });
-    installPrimitiveProcedure(
-        'caddr',
-        1,
-        function (M) {
-            var firstArg = checkCaddrPair(M, 'caddr', 0);
-            return firstArg.rest.rest.first;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)) {
+                return x.rest.rest;
+            } else {
+                raiseArgumentTypeError(M, "cddr", "cddrable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
         'caaar',
         1,
-        function (M) {
-            var firstArg = checkCaaarPair(M, 'caaar', 0);
-            return firstArg.first.first.first;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.first)) {
+                return x.first.first.first;
+            } else {
+                raiseArgumentTypeError(M, "caaar", "caaarable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
         'cdaar',
         1,
-        function (M) {
-            var firstArg = checkCdaarPair(M, 'cdaar', 0);
-            return firstArg.first.first.rest;
-        });
-    installPrimitiveProcedure(
-        'cddar',
-        1,
-        function (M) {
-            var firstArg = checkCddarPair(M, 'cddar', 0);
-            return firstArg.first.rest.rest;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.first)) {
+                return x.first.first.rest;
+            } else {
+                raiseArgumentTypeError(M, "cdaar", "cdaarable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
         'cadar',
         1,
-        function (M) {
-            var firstArg = checkCadarPair(M, 'cadar', 0);
-            return firstArg.first.rest.first;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.rest)) {
+                return x.first.rest.first;
+            } else {
+                raiseArgumentTypeError(M, "cadar", "cadarable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'cddar',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.rest)) {
+                return x.first.rest.rest;
+            } else {
+                raiseArgumentTypeError(M, "cddar", "cddarable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
         'caadr',
         1,
-        function (M) {
-            var firstArg = checkCaadrPair(M, 'caadr', 0);
-            return firstArg.rest.first.first;
-        });
-    installPrimitiveProcedure(
-        'cdddr',
-        1,
-        function (M) {
-            var firstArg = checkCdddrPair(M, 'cdddr', 0);
-            return firstArg.rest.rest.rest;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.first)) {
+                return x.rest.first.first;
+            } else {
+                raiseArgumentTypeError(M, "caadr", "caadrable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
         'cdadr',
         1,
-        function (M) {
-            var firstArg = checkCdadrPair(M, 'cdadr', 0);
-            return firstArg.rest.first.rest;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.first)) {
+                return x.rest.first.rest;
+            } else {
+                raiseArgumentTypeError(M, "cdadr", "cdadrable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'caddr',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.rest)) {
+                return x.rest.rest.first;
+            } else {
+                raiseArgumentTypeError(M, "caddr", "caddrable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'cdddr',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.rest)) {
+                return x.rest.rest.rest;
+            } else {
+                raiseArgumentTypeError(M, "cdddr", "cdddrable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
         'caaaar',
         1,
-        function (M) {
-            var firstArg = checkCaaaarPair(M, 'caaaar', 0);
-            return firstArg.first.first.first.first;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.first)&&isPair(x.first.first.first)) {
+                return x.first.first.first.first;
+            } else {
+                raiseArgumentTypeError(M, "caaaar", "caaaarable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
-        'caaadr',
+        'cdaaar',
         1,
-        function (M) {
-            var firstArg = checkCaaadrPair(M, 'caaadr', 0);
-            return firstArg.rest.first.first.first;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.first)&&isPair(x.first.first.first)) {
+                return x.first.first.first.rest;
+            } else {
+                raiseArgumentTypeError(M, "cdaaar", "cdaaarable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'cadaar',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.first)&&isPair(x.first.first.rest)) {
+                return x.first.first.rest.first;
+            } else {
+                raiseArgumentTypeError(M, "cadaar", "cadaarable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'cddaar',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.first)&&isPair(x.first.first.rest)) {
+                return x.first.first.rest.rest;
+            } else {
+                raiseArgumentTypeError(M, "cddaar", "cddaarable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
         'caadar',
         1,
-        function (M) {
-            var firstArg = checkCaadarPair(M, 'caadar', 0);
-            return firstArg.first.rest.first.first;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.rest)&&isPair(x.first.rest.first)) {
+                return x.first.rest.first.first;
+            } else {
+                raiseArgumentTypeError(M, "caadar", "caadarable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
-        'caaddr',
+        'cdadar',
         1,
-        function (M) {
-            var firstArg = checkCaaddrPair(M, 'caaddr', 0);
-            return firstArg.rest.rest.first.first;
-        });
-    installPrimitiveProcedure(
-        'cadddr',
-        1,
-        function (M) {
-            var firstArg = checkCadddrPair(M, 'cadddr', 0);
-            return firstArg.rest.rest.rest.first;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.rest)&&isPair(x.first.rest.first)) {
+                return x.first.rest.first.rest;
+            } else {
+                raiseArgumentTypeError(M, "cdadar", "cdadarable value", 0, x);
+            }
         });
     installPrimitiveProcedure(
         'caddar',
         1,
-        function (M) {
-            var firstArg = checkCaddarPair(M, 'caddar', 0);
-            return firstArg.first.rest.rest.first;
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.rest)&&isPair(x.first.rest.rest)) {
+                return x.first.rest.rest.first;
+            } else {
+                raiseArgumentTypeError(M, "caddar", "caddarable value", 0, x);
+            }
         });
+    installPrimitiveProcedure(
+        'cdddar',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.first)&&isPair(x.first.rest)&&isPair(x.first.rest.rest)) {
+                return x.first.rest.rest.rest;
+            } else {
+                raiseArgumentTypeError(M, "cdddar", "cdddarable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'caaadr',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.first)&&isPair(x.rest.first.first)) {
+                return x.rest.first.first.first;
+            } else {
+                raiseArgumentTypeError(M, "caaadr", "caaadrable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'cdaadr',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.first)&&isPair(x.rest.first.first)) {
+                return x.rest.first.first.rest;
+            } else {
+                raiseArgumentTypeError(M, "cdaadr", "cdaadrable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'cadadr',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.first)&&isPair(x.rest.first.rest)) {
+                return x.rest.first.rest.first;
+            } else {
+                raiseArgumentTypeError(M, "cadadr", "cadadrable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'cddadr',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.first)&&isPair(x.rest.first.rest)) {
+                return x.rest.first.rest.rest;
+            } else {
+                raiseArgumentTypeError(M, "cddadr", "cddadrable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'caaddr',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.rest)&&isPair(x.rest.rest.first)) {
+                return x.rest.rest.first.first;
+            } else {
+                raiseArgumentTypeError(M, "caaddr", "caaddrable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'cdaddr',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.rest)&&isPair(x.rest.rest.first)) {
+                return x.rest.rest.first.rest;
+            } else {
+                raiseArgumentTypeError(M, "cdaddr", "cdaddrable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'cadddr',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.rest)&&isPair(x.rest.rest.rest)) {
+                return x.rest.rest.rest.first;
+            } else {
+                raiseArgumentTypeError(M, "cadddr", "cadddrable value", 0, x);
+            }
+        });
+    installPrimitiveProcedure(
+        'cddddr',
+        1,
+        function(M) {
+            var x = M.e[M.e.length-1];
+            if (isPair(x)&&isPair(x.rest)&&isPair(x.rest.rest)&&isPair(x.rest.rest.rest)) {
+                return x.rest.rest.rest.rest;
+            } else {
+                raiseArgumentTypeError(M, "cddddr", "cddddrable value", 0, x);
+            }
+        });
+
+    // End autogenerated code.
+    //////////////////////////////////////////////////////////////////////
+    //////////////////////////////////////////////////////////////////////
+
+
     installPrimitiveProcedure(
         'pair?',
         1,
diff --git a/lang/kernel.rkt b/lang/kernel.rkt
index 3e0066e..8c31595 100644
--- a/lang/kernel.rkt
+++ b/lang/kernel.rkt
@@ -378,26 +378,36 @@ box?
 
   equal?
   eqv?
-
+  
   caar
   cdar
   cadr
-;;  cdar
   cddr
   caaar
-  caadr
-  cadar
   cdaar
-  cdadr
+  cadar
   cddar
+  caadr
+  cdadr
   caddr
   cdddr
-  cadddr
   caaaar
-  caaadr
+  cdaaar
+  cadaar
+  cddaar
   caadar
-  caaddr
+  cdadar
   caddar
+  cdddar
+  caaadr
+  cdaadr
+  cadadr
+  cddadr
+  caaddr
+  cdaddr
+  cadddr
+  cddddr
+  
   length
   list*
   list-ref