From a66d15e4e47636519c72c0bccf7e7fb937eaa624 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 30 Sep 2011 13:02:15 -0400 Subject: [PATCH] more primitives --- compiler/bootstrapped-primitives.rkt | 40 ++++++++++++++++++++++++++-- compiler/compiler.rkt | 6 ++++- compiler/kernel-primitives.rkt | 5 ++++ cs019/cs019.rkt | 3 ++- image/private/js-impl.js | 2 -- js-assembler/assemble-open-coded.rkt | 5 ++++ js-assembler/runtime-src/runtime.js | 2 ++ lang/kernel.rkt | 10 +++---- lang/posn.rkt | 11 ++++++++ lang/whalesong.rkt | 2 ++ version.rkt | 2 +- 11 files changed, 76 insertions(+), 12 deletions(-) create mode 100644 lang/posn.rkt diff --git a/compiler/bootstrapped-primitives.rkt b/compiler/bootstrapped-primitives.rkt index 5a17e2c..1211f5b 100644 --- a/compiler/bootstrapped-primitives.rkt +++ b/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) diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index 5cfee31..81929d6 100644 --- a/compiler/compiler.rkt +++ b/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])])) diff --git a/compiler/kernel-primitives.rkt b/compiler/kernel-primitives.rkt index 5817a90..fa17328 100644 --- a/compiler/kernel-primitives.rkt +++ b/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)] diff --git a/cs019/cs019.rkt b/cs019/cs019.rkt index 44d99ad..b3ce205 100644 --- a/cs019/cs019.rkt +++ b/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?])) diff --git a/image/private/js-impl.js b/image/private/js-impl.js index 39e5f84..57fac9b 100644 --- a/image/private/js-impl.js +++ b/image/private/js-impl.js @@ -1029,8 +1029,6 @@ EXPORTS['color-list->image'] = pinholeY); }); - - EXPORTS['image-width'] = makePrimitiveProcedure( 'image-width', diff --git a/js-assembler/assemble-open-coded.rkt b/js-assembler/assemble-open-coded.rkt index 86ac5d4..208e6f6 100644 --- a/js-assembler/assemble-open-coded.rkt +++ b/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)" diff --git a/js-assembler/runtime-src/runtime.js b/js-assembler/runtime-src/runtime.js index b7ede87..900853c 100644 --- a/js-assembler/runtime-src/runtime.js +++ b/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; diff --git a/lang/kernel.rkt b/lang/kernel.rkt index e12cb70..b51a294 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -361,13 +361,13 @@ box? map andmap ormap -memq -;; memv + memq + memv member -;; memf + memf assq -;; assv -;; assoc + assv + assoc ;; remove ;; filter ;; foldl diff --git a/lang/posn.rkt b/lang/posn.rkt new file mode 100644 index 0000000..aebba8e --- /dev/null +++ b/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)) diff --git a/lang/whalesong.rkt b/lang/whalesong.rkt index eca72d2..5bc2937 100644 --- a/lang/whalesong.rkt +++ b/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) diff --git a/version.rkt b/version.rkt index c39513d..a5d2825 100644 --- a/version.rkt +++ b/version.rkt @@ -6,4 +6,4 @@ (provide version) (: version String) -(define version "1.43") +(define version "1.44")