From a3d5ec0b8666858a9fe5fa7da1493926b652ec22 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Tue, 29 Mar 2011 21:49:11 -0400 Subject: [PATCH] moved the type check stuff into the compiler --- assemble-open-coded.rkt | 229 ++++++++++++-------------------------- browser-evaluate.rkt | 2 +- compile.rkt | 34 +++--- simulator.rkt | 1 + test-browser-evaluate.rkt | 112 ++++++++++++++++++- 5 files changed, 203 insertions(+), 175 deletions(-) diff --git a/assemble-open-coded.rkt b/assemble-open-coded.rkt index 9258181..f9dd883 100644 --- a/assemble-open-coded.rkt +++ b/assemble-open-coded.rkt @@ -13,135 +13,82 @@ (: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String)) (define (open-code-kernel-primitive-procedure op) - (let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)] - [rand-knowledge : (Listof CompileTimeEnvironmentEntry) - (CallKernelPrimitiveProcedure-operands-knowledge op)] - [rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))]) + (let*: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)] + [operands : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))] + [checked-operands : (Listof String) + (map maybe-typecheck-operand + (CallKernelPrimitiveProcedure-expected-operand-types op) + (build-list (length operands) (lambda: ([i : Natural]) i)) + operands + (CallKernelPrimitiveProcedure-typechecks? op))]) (case operator - [(+) - (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals)) - rand-vals - rand-knowledge)]) - (cond [(empty? rand-vals) - "0"] - [else - (string-append "(" (string-join checked-rands " + ") ")")]))] + (cond [(empty? checked-operands) + "0"] + [else + (string-append "(" (string-join checked-operands " + ") ")")])] [(-) - (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals)) - rand-vals - rand-knowledge)]) - (cond [(empty? rand-vals) - (error '- "Expects at least 1 argument, given 0")] - [(empty? (rest rand-vals)) - (format "(-(~a))" (first rand-vals))] - [else - (string-append "(" (string-join checked-rands "-") ")")]))] - + (cond [(empty? (rest checked-operands)) + (format "(-(~a))" (first checked-operands))] + [else + (string-append "(" (string-join checked-operands "-") ")")])] + [(*) - (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals)) - rand-vals - rand-knowledge)]) - (cond [(empty? rand-vals) - "1"] - [else - (string-append "(" (string-join checked-rands "*") ")")]))] + (cond [(empty? checked-operands) + "1"] + [else + (string-append "(" (string-join checked-operands "*") ")")])] [(/) - (let ([checked-rands (maybe-typecheck-operands (repeat 'number (length rand-vals)) - rand-vals - rand-knowledge)]) - (cond [(empty? rand-vals) - (error '/ "Expects at least 1 argument, given 0")] - [else - (string-append "(" (string-join checked-rands "/") ")")]))] + (string-append "(" (string-join checked-operands "/") ")")] [(add1) - (unless (= 1 (length rand-vals)) - (error 'add1 "Expected one argument")) - (format "(~a + 1)" - (maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))] + (format "(~a + 1)" (first checked-operands))] [(sub1) - (unless (= 1 (length rand-vals)) - (error 'sub1 "Expected one argument")) - (format "(~a - 1)" - (maybe-typecheck-operand 'number 0 (first rand-vals) (first rand-knowledge)))] + (format "(~a - 1)" (first checked-operands))] [(<) - (unless (> (length rand-vals) 0) - (error '< "Expected at least one argument")) - (assemble-chain "<" (maybe-typecheck-operands (repeat 'number (length rand-vals)) - rand-vals - rand-knowledge))] + (assemble-chain "<" checked-operands)] + [(<=) - (unless (> (length rand-vals) 0) - (error '<= "Expected at least one argument")) - (assemble-chain "<=" (maybe-typecheck-operands (repeat 'number (length rand-vals)) - rand-vals - rand-knowledge))] + (assemble-chain "<=" checked-operands)] [(=) - (unless (> (length rand-vals) 0) - (error '= "Expected at least one argument")) - (assemble-chain "==" (maybe-typecheck-operands (repeat 'number (length rand-vals)) - rand-vals - rand-knowledge))] + (assemble-chain "===" checked-operands)] [(>) - (unless (> (length rand-vals) 0) - (error '> "Expected at least one argument")) - (assemble-chain ">" (maybe-typecheck-operands (repeat 'number (length rand-vals)) - rand-vals - rand-knowledge))] + (assemble-chain ">" checked-operands)] [(>=) - (unless (> (length rand-vals) 0) - (error '>= "Expected at least one argument")) - (assemble-chain ">=" (maybe-typecheck-operands (repeat 'number (length rand-vals)) - rand-vals - rand-knowledge))] + (assemble-chain ">=" checked-operands)] [(cons) - (unless (= (length rand-vals) 2) - (error 'cons "Expected two arguments")) - (format "[~a, ~a]" (first rand-vals) (second rand-vals))] + (format "[~a, ~a]" (first checked-operands) (second checked-operands))] [(car) - (unless (= (length rand-vals) 1) - (error 'car "Expected one argument")) - (format "(~a)[0]" (maybe-typecheck-operand 'pair 0 (first rand-vals) - (first rand-knowledge)))] + (format "(~a)[0]" (first checked-operands))] [(cdr) - (unless (= (length rand-vals) 1) - (error 'cdr "Expected one argument")) - (format "(~a)[1]" (maybe-typecheck-operand 'pair 0 (first rand-vals) - (first rand-knowledge)))] + (format "(~a)[1]" (first checked-operands))] [(list) - (let loop ([rand-vals rand-vals]) + (let loop ([checked-operands checked-operands]) (cond - [(empty? rand-vals) + [(empty? checked-operands) "Primitives.null"] [else - (format "[~a,~a]" (first rand-vals) (loop (rest rand-vals)))]))] + (format "[~a,~a]" (first checked-operands) (loop (rest checked-operands)))]))] [(null?) - (unless (= (length rand-vals) 1) - (error 'null? "Expected one argument")) - (format "(~a === Primitives.null)" - (first rand-vals))] + (format "(~a === Primitives.null)" (first checked-operands))] + [(not) - (unless (= (length rand-vals) 1) - (error 'not? "Expected one argument")) - (format "(!~a)" (first rand-vals))] + (format "(!(~a))" (first checked-operands))] [(eq?) - (unless (= (length rand-vals) 2) - (error 'eq? "Expected 2 arguments")) - (format "(~a === ~a)" (first rand-vals) (second rand-vals))]))) + (format "(~a === ~a)" (first checked-operands) (second checked-operands))]))) (: assemble-chain (String (Listof String) -> String)) @@ -165,72 +112,40 @@ (: assemble-domain-check (OperandDomain String Natural -> String)) (define (assemble-domain-check domain operand-string pos) - (let ([test-string - (case domain - [(number) - (format "(typeof(~a) === 'number')" - operand-string)] - [(string) - (format "(typeof(~a) === 'string')" - operand-string)] - [(list) - (format "(~a === [] || (typeof(~a) === 'object' && (~a).length === 2))" - operand-string operand-string operand-string)] - [(pair) - (format "(typeof(~a) === 'object' && (~a).length === 2)" - operand-string operand-string)])]) - (format "((~a) ? (~a) : raise(new Error('Expected ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))" - test-string - operand-string - (symbol->string domain) - pos - operand-string))) - -(: maybe-typecheck-operands ((Listof OperandDomain) - (Listof String) - (Listof CompileTimeEnvironmentEntry) -> (Listof String))) -(define (maybe-typecheck-operands expected-domains rand-vals rand-knowledge) - (map (lambda: ([rand : String] - [expected-domain : OperandDomain] - [knowledge : CompileTimeEnvironmentEntry] - [position : Natural]) - (maybe-typecheck-operand expected-domain position rand knowledge)) - rand-vals - expected-domains - rand-knowledge - (build-list (length rand-vals) - (lambda: ([i : Natural]) i)))) - - -(: maybe-typecheck-operand (OperandDomain Natural String CompileTimeEnvironmentEntry -> String)) -;; Adds typechecks if we can't prove that the operand is of the required type. -(define (maybe-typecheck-operand domain-type position operand-string knowledge) (cond - [(redundant-check? domain-type knowledge) + [(eq? domain 'any) operand-string] [else - (assemble-domain-check domain-type operand-string position)])) + (let: ([test-string : String + (case domain + [(number) + (format "(typeof(~a) === 'number')" + operand-string)] + [(string) + (format "(typeof(~a) === 'string')" + operand-string)] + [(list) + (format "(~a === [] || (typeof(~a) === 'object' && (~a).length === 2))" + operand-string operand-string operand-string)] + [(pair) + (format "(typeof(~a) === 'object' && (~a).length === 2)" + operand-string operand-string)] + [(box) + (format "(typeof(~a) === 'object' && (~a).length === 1)" + operand-string operand-string)])]) + (format "((~a) ? (~a) : raise(new Error('Expected ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))" + test-string + operand-string + (symbol->string domain) + (add1 pos) + operand-string))])) -(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean)) -;; Produces true if we know the knowledge implies the domain-type. -(define (redundant-check? domain-type knowledge) - (cond [(Const? knowledge) - (case domain-type - [(number) - (number? (Const-const knowledge))] - [(string) - (string? (Const-const knowledge))] - [(box) - (box? (Const-const knowledge))] - [(list) - (list? (Const-const knowledge))] - [(pair) - (pair? (Const-const knowledge))])] - [else - #f])) - - -(: repeat (All (A) (A Natural -> (Listof A)))) -(define (repeat x n) - (build-list n (lambda (i) x))) \ No newline at end of file +(: maybe-typecheck-operand (OperandDomain Natural String Boolean -> String)) +;; Adds typechecks if we can't prove that the operand is of the required type. +(define (maybe-typecheck-operand domain-type position operand-string typecheck?) + (cond + [typecheck? + (assemble-domain-check domain-type operand-string position)] + [else + operand-string])) diff --git a/browser-evaluate.rkt b/browser-evaluate.rkt index abdc055..49ac626 100644 --- a/browser-evaluate.rkt +++ b/browser-evaluate.rkt @@ -235,7 +235,7 @@ var comet = function() { "&b=" + encodeURIComponent(String(BrowserDetect.browser + ' ' + BrowserDetect.version + '/' + BrowserDetect.OS))); }; - var onFail = function(e) { + var onFail = function(machine, e) { endTime = new Date(); sendRequest("/eval", function(req) { setTimeout(comet, 0); }, "e=" + encodeURIComponent(String(e)) + diff --git a/compile.rkt b/compile.rkt index 0f919a4..9792799 100644 --- a/compile.rkt +++ b/compile.rkt @@ -503,22 +503,24 @@ (: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean)) ;; Produces true if we know the knowledge implies the domain-type. (define (redundant-check? domain-type knowledge) - (cond [(Const? knowledge) - (case domain-type - [(number) - (number? (Const-const knowledge))] - [(string) - (string? (Const-const knowledge))] - [(box) - (box? (Const-const knowledge))] - [(list) - (list? (Const-const knowledge))] - [(pair) - (pair? (Const-const knowledge))] - [(any) - #t])] - [else - #f])) + (cond + [(eq? domain-type 'any) + #t] + [else + (cond [(Const? knowledge) + (case domain-type + [(number) + (number? (Const-const knowledge))] + [(string) + (string? (Const-const knowledge))] + [(box) + (box? (Const-const knowledge))] + [(list) + (list? (Const-const knowledge))] + [(pair) + (pair? (Const-const knowledge))])] + [else + #f])])) (: all-operands-are-constant-or-stack-references ((Listof Expression) -> (U False (Listof OpArg)))) diff --git a/simulator.rkt b/simulator.rkt index 392943b..51a2a24 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -9,6 +9,7 @@ "lexical-structs.rkt" "simulator-structs.rkt" "bootstrapped-primitives.rkt" + "kernel-primitives.rkt" racket/list racket/match (for-syntax racket/base)) diff --git a/test-browser-evaluate.rkt b/test-browser-evaluate.rkt index 871419e..70f07d8 100644 --- a/test-browser-evaluate.rkt +++ b/test-browser-evaluate.rkt @@ -32,7 +32,6 @@ EOF ))) -;; test-find-toplevel-variables (define-syntax (test stx) (syntax-case stx () [(_ s exp) @@ -48,12 +47,123 @@ EOF #'stx))) (printf " ok (~a milliseconds)\n" (evaluated-t result))))))])) +(define-syntax (test/exn stx) + (syntax-case stx () + [(_ s exp) + (with-syntax ([stx stx]) + (syntax/loc #'stx + (begin + (printf "running test...") + (let ([an-error-happened + (with-handlers ([error-happened? + (lambda (exn) + exn)]) + (let ([r (evaluate s)]) + (raise-syntax-error #f (format "Expected exception, but got ~s" r) + #'stx)))]) + (unless (string=? exp (error-happened-str an-error-happened)) + (printf " error!\n") + (raise-syntax-error #f (format "Expected ~s, got ~s" exp (error-happened-str an-error-happened)) + #'stx)) + (printf " ok (~a milliseconds)\n" (error-happened-t an-error-happened))))))])) + + + (test '(display 42) "42") (test '(display (+ 3 4)) "7") +(test/exn (evaluate '(+ "hello" 3)) + "Error: Expected number as argument 1 but received hello") + + +(test '(display (/ 100 4)) + "25") +(test/exn (evaluate '(/ 3 'four)) + "Error: Expected number as argument 2 but received four") + + +(test '(display (- 1)) + "-1") + +(test/exn '(- 'one) + "Error: Expected number as argument 1 but received one") + +(test '(display (- 5 4)) + "1") + +(test '(display (* 3 17)) + "51") + +(test/exn '(* "three" 17) + "Error: Expected number as argument 1 but received three") + +(test '(display '#t) + "true") + +(test '(display '#f) + "false") + +(test '(displayln (not #t)) + "false\n") + +(test '(displayln (not #f)) + "true\n") + +(test '(displayln (not 3)) + "false\n") + +(test '(displayln (not (not 3))) + "true\n") + +(test '(displayln (add1 1)) + "2\n") + +(test/exn '(displayln (add1 "0")) + "Error: Expected number as argument 1 but received 0") + +(test '(displayln (sub1 1)) + "0\n") + +(test/exn '(displayln (sub1 "0")) + "Error: Expected number as argument 1 but received 0") + +(test '(displayln (< 1 2)) + "true\n") + +(test '(displayln (<= 1 2)) + "true\n") + +(test '(displayln (= 1 2)) + "false\n") + +(test '(displayln (> 1 2)) + "false\n") + +(test '(displayln (>= 1 2)) + "false\n") + +(test '(displayln (car (cons 3 4))) + "3\n") + +(test '(displayln (cdr (cons 3 4))) + "4\n") + +(test '(displayln (let ([x (cons 5 6)]) + (car x))) + "5\n") + +(test '(displayln (let ([x (cons 5 6)]) + (cdr x))) + "6\n") + +(test '(displayln (length (list 'hello 4 5))) + "3\n") + + + (test '(begin (define (f x) (if (= x 0) 0