more primitives

compiler/bootstrapped-primitives.rkt

@@ -181,7 +181,26 @@
                                        l
                                        (memq x (cdr l)))))])
                     memq))
-
+   (make-bootstrapped-primitive-code
+    'memv
+    '(letrec-values ([(memv) (lambda (x l)
+                               (if (null? l)
+                                   #f
+                                   (if (eqv? x (car l))
+                                       l
+                                       (memv x (cdr l)))))])
+                    memv))
+   
+   (make-bootstrapped-primitive-code
+    'memf
+    '(letrec-values ([(memf) (lambda (x f l)
+                               (if (null? l)
+                                   #f
+                                   (if (f x)
+                                       l
+                                       (memf x f (cdr l)))))])
+                    memf))
+   
    (make-bootstrapped-primitive-code
     'assq
     '(letrec-values ([(assq) (lambda (x l)
@@ -191,7 +210,24 @@
                                        (car l)
                                        (assq x (cdr l)))))])
                     assq))
-
+   (make-bootstrapped-primitive-code
+    'assv
+    '(letrec-values ([(assv) (lambda (x l)
+                               (if (null? l)
+                                   #f
+                                   (if (eqv? x (caar l))
+                                       (car l)
+                                       (assv x (cdr l)))))])
+                    assv))
+   (make-bootstrapped-primitive-code
+    'assoc
+    '(letrec-values ([(assoc) (lambda (x l)
+                               (if (null? l)
+                                   #f
+                                   (if (equal? x (caar l))
+                                       (car l)
+                                       (assoc x (cdr l)))))])
+                    assoc))   
    (make-bootstrapped-primitive-code
     'length
     '(letrec-values ([(length-iter) (lambda (l i)

compiler/compiler.rkt

@@ -1244,7 +1244,11 @@
               [(list)
                (list? (Const-const knowledge))]
               [(pair)
-               (pair? (Const-const knowledge))])]
+               (pair? (Const-const knowledge))]
+              [(caarpair)
+               (let ([x (Const-const knowledge)])
+                 (and (pair? x)
+                      (pair? (car x))))])]
            [else
             #f])]))
 

compiler/kernel-primitives.rkt

@@ -9,6 +9,7 @@
                               'box
                               'list
                               'pair
+                              'caarpair
                               'any))
 
 
@@ -102,6 +103,7 @@
                                            '>=
                                            'cons
                                            'car
+                                           'caar
                                            'cdr
                                            'list
                                            'list?
@@ -189,6 +191,9 @@
 
     [(eq? prim 'car)
      (list 'pair)]
+
+    [(eq? prim 'caar)
+     (list 'caarpair)]
     
     [(eq? prim 'cdr)
      (list 'pair)]

cs019/cs019.rkt

@@ -460,4 +460,5 @@
     [(eq? (member x L) #f) #f]
     [else #t]))
 
-(provide (rename-out [-member member]))
+(provide (rename-out [-member member]
+                     [-member member?]))

image/private/js-impl.js

@@ -1029,8 +1029,6 @@ EXPORTS['color-list->image'] =
                                     pinholeY);
         });
 
-
-
 EXPORTS['image-width'] = 
     makePrimitiveProcedure(
         'image-width',

js-assembler/assemble-open-coded.rkt

@@ -79,6 +79,9 @@
 
           [(car)
            (format "(~a).first" (first checked-operands))]
+
+          [(caar)
+           (format "(~a).first.first" (first checked-operands))]
           
           [(cdr)
            (format "(~a).rest" (first checked-operands))]
@@ -164,6 +167,8 @@
                             (format "RT.isList")]
                            [(pair)
                             (format "RT.isPair")]
+                           [(caarpair)
+                            (format "RT.isCaarPair")]
                            [(box)
                             (format "RT.isBox")])])
            (format "RT.testArgument(M,~s,~a,~a,~a,~s)"

js-assembler/runtime-src/runtime.js

@@ -22,6 +22,7 @@
     var isNatural = baselib.numbers.isNatural;
     var isReal = baselib.numbers.isReal;
     var isPair = baselib.lists.isPair;
+    var isCaarPair = function(x) { return isPair(x) && isPair(x.first); };
     var isList = baselib.lists.isList;
     var isVector = baselib.vectors.isVector;
     var isString = baselib.strings.isString;
@@ -800,6 +801,7 @@
 
     // Type predicates
     exports['isPair'] = isPair;
+    exports['isCaarPair'] = isCaarPair;
     exports['isList'] = isList;
     exports['isVector'] = isVector;
     exports['isOutputPort'] = isOutputPort;

lang/kernel.rkt

@@ -361,13 +361,13 @@ box?
   map
   andmap
   ormap
-memq
+  memq
-;;  memv
+  memv
   member
-;;  memf
+  memf
   assq
-;;  assv
+  assv
-;;  assoc
+  assoc
 ;;  remove
 ;;  filter
 ;;  foldl

lang/posn.rkt

@@ -0,0 +1,11 @@
+#lang s-exp "kernel.rkt"
+
+;; The posn struct for the teaching languages
+(provide struct:posn make-posn posn? posn-x posn-y set-posn-x! set-posn-y!
+         posn #;(rename-out (posn posn-id)))
+
+(struct posn (x y) #:mutable #:transparent)
+
+;; We define a separate function so tha it has the 
+;; name `make-posn':
+(define (make-posn x y) (posn x y))

lang/whalesong.rkt

@@ -14,6 +14,7 @@
          "private/shared.rkt"
          "check-expect/check-expect.rkt"
          "bool.rkt"
+         "posn.rkt"
          (for-syntax racket/base))
 
 ;; Programs written in Whalesong will have tracing enabled by default.
@@ -28,6 +29,7 @@
                      [my-define-struct define-struct])
          shared
          (all-from-out "bool.rkt")
+         (all-from-out "posn.rkt")
          (except-out (all-from-out "check-expect/check-expect.rkt")
                      run-tests)
 

version.rkt

@@ -6,4 +6,4 @@
 
 (provide version)
 (: version String)
-(define version "1.43")
+(define version "1.44")