diff --git a/cs019/cs019.rkt b/cs019/cs019.rkt index b3ce205..865aa8e 100644 --- a/cs019/cs019.rkt +++ b/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 diff --git a/js-assembler/runtime-src/baselib-primitives.js b/js-assembler/runtime-src/baselib-primitives.js index 9db13eb..d991230 100644 --- a/js-assembler/runtime-src/baselib-primitives.js +++ b/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?', diff --git a/lang/kernel.rkt b/lang/kernel.rkt index b51a294..8ada77c 100644 --- a/lang/kernel.rkt +++ b/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? @@ -447,12 +442,12 @@ symbol->string char-ci>? char-ci<=? char-ci>=? -;; char-alphabetic? -;; char-numeric? -;; char-whitespace? -;; char-upper-case? -;; char-lower-case? -;; char->integer + char-alphabetic? + char-numeric? + char-whitespace? + char-upper-case? + char-lower-case? + char->integer integer->char char-upcase char-downcase diff --git a/lang/private/list.rkt b/lang/private/list.rkt index 953e5a1..f5586e1 100644 --- a/lang/private/list.rkt +++ b/lang/private/list.rkt @@ -34,8 +34,8 @@ build-string build-list - #;compose - #;compose1 + compose + 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)