adding bindings for the teaching primitives

cs019/cs019.rkt

@@ -1,4 +1,4 @@
-#lang s-exp "../lang/kernel.rkt"
+#lang s-exp "../lang/base.rkt"
 
 ;; Like the big whalesong language, but with additional ASL restrictions.
 
@@ -23,7 +23,19 @@
                      case
                      when
                      unless
-                     member))
+                     member)
+
+         string-ith
+         replicate
+         int->string
+         string->int
+         explode
+         implode
+         string-numeric?
+         string-alphabetic?
+         string-whitespace?
+         string-upper-case?
+         string-lower-case?)
                      
 
 (require "../image.rkt")
@@ -454,6 +466,122 @@
 
 
 
+
+(define 1-LET "1-letter string")
+(define 1-LETTER (format "~a" 1-LET))
+(define 1-LETTER* (format "list of ~as" 1-LET))
+(define NAT "natural number")
+
+;; Symbol Any -> Boolean 
+;; is this a 1-letter string?
+(define (1-letter? tag s)
+  (unless (string? s) (err tag "expected a ~a, but received a string: ~e" 1-LETTER s))
+  (= (string-length s) 1))
+
+;; Symbol Any -> Boolean 
+;; is s a list of 1-letter strings
+;; effect: not a list, not a list of strings 
+(define (1-letter*? tag s)
+  (unless (list? s) (err tag "expected a ~a, but received: ~e" 1-LETTER* s))
+  (for-each 
+   (lambda (c) 
+     (unless (string? c) (err tag "expected a ~a, but received: ~e" 1-LETTER* c)))
+   s)
+  (andmap (compose (lambda (x) (= x 1)) string-length) s))
+
+
+(define (err tag msg-format . args)
+  (raise 
+   (make-exn:fail:contract
+    (apply format (string-append (symbol->string tag) ": " msg-format) args)
+    (current-continuation-marks))))
+
+(define (a-or-an after)
+  (if (member (string-ref (format "~a" after) 0) '(#\a #\e #\i #\o #\u))
+      "an" "a"))
+
+(define cerr 
+  (case-lambda
+    [(tag check-result format-msg actual)
+     (unless check-result
+       (err tag (string-append "expected " (a-or-an format-msg) " " format-msg ", but received ~e") actual))]
+    [(tag check-result format-msg actual snd)
+     (unless check-result
+       (err tag (string-append "expected " (a-or-an format-msg) " " format-msg " for the ~a argument, but received ~e")
+            snd actual))]))
+
+(define string-ith
+  (lambda (s n)
+    (define f "exact integer in [0, length of the given string]")
+    (cerr 'string-ith (string? s) "string" s "first")
+    (cerr 'string-ith (and (number? n) (integer? n) (>= n 0)) NAT n "second")
+    (let ([l (string-length s)]) 
+      (cerr 'string-ith (< n l) f n "second"))
+    (string (string-ref s n))))
+
+
+
+(define replicate 
+  (lambda (n s1)
+    (cerr 'replicate (and (number? n) (exact-integer? n) (>= n 0)) NAT n)
+    (cerr 'replicate (string? s1) "string" s1)
+    (apply string-append (build-list n (lambda (i) s1)))))
+
+(define int->string 
+  (lambda (i) 
+    (cerr 'int->string 
+          (and (exact-integer? i) (or (<= 0 i 55295) (<= 57344 i 1114111)))
+          "exact integer in [0,55295] or [57344 1114111]"
+          i)
+    (string (integer->char i))))
+
+(define string->int 
+  (lambda (s) 
+    (cerr 'string->int (1-letter? 'string->int s) 1-LETTER s)
+    (char->integer (string-ref s 0))))
+
+
+(define explode 
+  (lambda (s)
+    (cerr 'explode (string? s) "string" s)
+    (map string (string->list s))))
+
+(define implode
+  (lambda (los)
+    (cerr 'implode (1-letter*? 'implode los) 1-LETTER* los)
+    (apply string-append los)))
+
+
+
+(define string-numeric? 
+  ;; is this: (number? (string->number s)) enough?
+  (lambda (s1)
+    (cerr 'string-numeric? (string? s1) "string" s1)
+    (andmap char-numeric? (string->list s1))))
+
+(define string-alphabetic? 
+  (lambda (s1)
+    (cerr 'string-alphabetic? (string? s1) "string" s1)
+    (andmap char-alphabetic? (string->list s1))))
+
+
+(define string-whitespace? 
+  (lambda (s)
+    (cerr 'string-upper-case? (string? s)  "string" s)
+    (andmap char-whitespace? (string->list s))))
+
+(define string-upper-case? 
+  (lambda (s)
+    (cerr 'string-upper-case? (string? s) "string" s)
+    (andmap char-upper-case? (string->list s))))
+
+
+(define string-lower-case? 
+  (lambda (s)
+    (cerr 'string-lower-case? (string? s) "string" s)
+    (andmap char-lower-case? (string->list s))))
+
+
 ;; ASL's member returns booleans.
 (define (-member x L)
   (cond

js-assembler/runtime-src/baselib-primitives.js

@@ -19,7 +19,7 @@
     var isInexact = baselib.numbers.isInexact;
     var isComplex = baselib.numbers.isComplex;
     var isRational = baselib.numbers.isRational;
-
+    var isBytes = baselib.bytes.isBytes;
 
     var isNatural = baselib.numbers.isNatural;
     var isPair = baselib.lists.isPair;
@@ -1180,6 +1180,13 @@
 
 
 
+    installPrimitiveProcedure(
+        'char->integer',
+        1,
+        function(M) {
+            return checkChar(M, 'char->integer', 0).val.charCodeAt(0);
+        });
+
     installPrimitiveProcedure(
         'integer->char',
         1,
@@ -1204,7 +1211,48 @@
             return baselib.chars.makeChar(ch.toLowerCase());
         });
 
+    installPrimitiveProcedure(
+        'char-numeric?',
+        1,
+        function(M) {
+            var val = checkChar(M, 'char-numeric?', 0).val;
+            return val >= '0' && val <= '9';
+        });
 
+    installPrimitiveProcedure(
+        'char-alphabetic?',
+        1,
+        function(M) {
+            var val = checkChar(M, 'char-alphabetic?', 0).val;
+            return ((val >= 'a' && val <= 'z') ||
+                    (val >= 'A' && val <= 'Z'));
+        });
+
+    var whitespaceRegexp = new RegExp("^\\s*$");
+    installPrimitiveProcedure(
+        'char-whitespace?',
+        1,
+        function(M) {
+            var val = checkChar(M, 'char-whitespace?', 0).val;
+            return val.match(whitespaceRegexp ? true : false);
+      });
+
+
+    installPrimitiveProcedure(
+        'char-upper-case?',
+        1,
+        function(M) {
+            var val = checkChar(M, 'char-upper-case?', 0).val;
+            return val === val.toUpperCase();
+      });
+
+    installPrimitiveProcedure(
+        'char-lower-case?',
+        1,
+        function(M) {
+            var val = checkChar(M, 'char-lower-case?', 0).val;
+            return val === val.toLowerCase();
+      });
 
 
     installPrimitiveProcedure(
@@ -1447,6 +1495,23 @@
 	    return isComplex(M.e[M.e.length - 1]);
 	});
 
+    installPrimitiveProcedure(
+        'bytes?',
+        1,
+        function(M) {
+            return isBytes(M.e[M.e.length-1]);
+        });
+
+    installPrimitiveProcedure(
+	'byte?',
+	1,
+	function(M) {
+	    var v = M.e[M.e.length - 1];
+            if(!isNatural(v)) { return false; }
+            v = baselib.numbers.toFixnum(v);
+            return v >= 0 && v < 256;
+	});
+
     installPrimitiveProcedure(
 	'rational?',
 	1,
@@ -1678,6 +1743,13 @@
             return baselib.numbers.isInteger(M.e[M.e.length - 1]);
         });
 
+    installPrimitiveProcedure(
+        'exact-integer?',
+        1,
+        function (M) {
+            return (baselib.numbers.isInteger(M.e[M.e.length - 1]) &&
+                    baselib.numbers.isExact(M.e[M.e.length - 1]));
+        });
 
     installPrimitiveProcedure(
         'exact-nonnegative-integer?',

lang/kernel.rkt

@@ -126,10 +126,12 @@
 	 prefix-in
 	 only-in
          rename-in
+         except-in
 	 provide
 	 planet
 	 all-defined-out
 	 all-from-out
+         prefix-out
 	 except-out
 	 rename-out
 	 struct-out
@@ -316,14 +318,14 @@ char?
 boolean?
 vector?
 struct?
-;;  eof-object?
 ;;  bytes?
-;;  byte?
+byte?
 number?
 complex?
 real?
 rational?
 integer?
+exact-integer?
 exact?
 exact-nonnegative-integer?
 inexact?
@@ -368,12 +370,7 @@ box?
   assq
   assv
   assoc
-;;  remove
-;;  filter
-;;  foldl
-;;  foldr
 ;;  sort
-;;  build-list
   box
 ;;  box-immutable
   unbox
@@ -410,7 +407,6 @@ symbol->string
   format
   printf
   fprintf
-;;  build-string
 ;;  string->immutable-string
   string-set!
 ;;  string-fill!
@@ -436,7 +432,6 @@ symbol->string
   vector-set!
   vector->list
   list->vector
-;;  build-vector
   char=?
   char<?
   char>?
@@ -447,12 +442,12 @@ symbol->string
   char-ci>?
   char-ci<=?
   char-ci>=?
-;;  char-alphabetic?
+  char-alphabetic?
-;;  char-numeric?
+  char-numeric?
-;;  char-whitespace?
+  char-whitespace?
-;;  char-upper-case?
+  char-upper-case?
-;;  char-lower-case?
+  char-lower-case?
-;;  char->integer
+  char->integer
   integer->char
   char-upcase
   char-downcase

lang/private/list.rkt

@@ -34,8 +34,8 @@
          build-string
          build-list
 
-         #;compose
+         compose
-         #;compose1
+         compose1
          )
 
 (require (only-in "../unsafe/ops.rkt" unsafe-car unsafe-cdr))
@@ -313,14 +313,14 @@
           [else (cons (fcn j)
                       (recr (add1 j) (sub1 i)))])))
 
-#;(define-values [compose1 compose]
+(define-values [compose1 compose]
   (let ()
     (define-syntax-rule (app1 E1 E2) (E1 E2))
     (define-syntax-rule (app* E1 E2) (call-with-values (lambda () E2) E1))
     (define-syntax-rule (mk-simple-compose app f g)
       (let*-values
           ([(arity) (procedure-arity g)]
-           [(required-kwds allowed-kwds) (procedure-keywords g)]
+           [(required-kwds allowed-kwds) (values '() '())  #; (procedure-keywords g)]
            [(composed)
             ;; FIXME: would be nice to use `procedure-reduce-arity' and
             ;; `procedure-reduce-keyword-arity' in the places marked below,
@@ -331,14 +331,14 @@
                   [(x)   (app f (g x))]
                   [(x y) (app f (g x y))]
                   [args  (app f (apply g args))]))])
-        (if (null? allowed-kwds)
+        composed #;(if (null? allowed-kwds)
             composed
             (make-keyword-procedure   ; <--- and here
              (lambda (kws kw-args . xs)
                (app f (keyword-apply g kws kw-args xs)))
              composed))))
     (define-syntax-rule (can-compose* name n g f fs)
-      (unless (null? (let-values ([(req _) (procedure-keywords g)]) req))
+      (unless (null? (let-values ([(req _) (values '() '()) #;(procedure-keywords g)]) req))
         (apply raise-type-error 'name "procedure (no required keywords)"
                n f fs)))
     (define-syntax-rule (can-compose1 name n g f fs)