From c96e12fac19a79616d4f7c9261589b7ad9f4b58b Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 19 Sep 2011 14:02:00 -0400 Subject: [PATCH 1/2] working on making the cs019 language for SK --- cs019/cs019.rkt | 432 +++++++++++++++++- js-assembler/runtime-src/baselib-check.js | 15 +- js-assembler/runtime-src/baselib-contmarks.js | 15 +- .../runtime-src/baselib-exceptions.js | 10 - .../runtime-src/baselib-primitives.js | 153 +++++-- js-assembler/runtime-src/runtime.js | 5 +- lang/kernel.rkt | 23 +- 7 files changed, 587 insertions(+), 66 deletions(-) diff --git a/cs019/cs019.rkt b/cs019/cs019.rkt index 938a8eb..5ae0db9 100644 --- a/cs019/cs019.rkt +++ b/cs019/cs019.rkt @@ -1,6 +1,434 @@ -#lang s-exp "../lang/whalesong.rkt" +#lang s-exp "../lang/kernel.rkt" ;; Like the big whalesong language, but with additional ASL restrictions. +(require (for-syntax racket/base syntax/stx) + (only-in "../lang/whalesong.rkt")) -(provide (all-from-out "../lang/whalesong.rkt")) \ No newline at end of file +(provide (except-out (all-from-out "../lang/whalesong.rkt") + if + cond + case + when + unless + member)) + + + + + + +(define-for-syntax (local-expand-for-error stx ctx stops) + ;; This function should only be called in an 'expression + ;; context. In case we mess up, avoid bogus error messages. + (when (memq (syntax-local-context) '(expression)) + (local-expand stx ctx stops))) + + + + + + +;; Raise a syntax error: +(define-for-syntax (teach-syntax-error form stx detail msg . args) + (let ([form (if (eq? form '|function call|) + form + #f)] ; extract name from stx + [msg (apply format msg args)]) + (if detail + (raise-syntax-error form msg stx detail) + (raise-syntax-error form msg stx)))) + +(define-for-syntax (teach-syntax-error* form stx details msg . args) + (let ([exn (with-handlers ([exn:fail:syntax? + (lambda (x) x)]) + (apply teach-syntax-error form stx #f msg args))]) + (raise + (make-exn:fail:syntax + (exn-message exn) + (exn-continuation-marks exn) + details)))) + + + +;; The syntax error when a form's name doesn't follow a "(" +(define-for-syntax (bad-use-error name stx) + (teach-syntax-error + name + stx + #f + "found a use of `~a' that does not follow an open parenthesis" + name)) + +(define-for-syntax (something-else v) + (let ([v (syntax-e v)]) + (cond + [(number? v) "a number"] + [(string? v) "a string"] + [else "something else"]))) + +;; verify-boolean is inserted to check for boolean results: +(define (verify-boolean b where) + (if (or (eq? b #t) (eq? b #f)) + b + (raise + (make-exn:fail:contract + (format "~a: question result is not true or false: ~e" where b) + (current-continuation-marks))))) + +(define-syntax (-cond stx) + (syntax-case stx () + [(_) + (teach-syntax-error + 'cond + stx + #f + "expected a question--answer clause after `cond', but nothing's there")] + [(_ clause ...) + (let* ([clauses (syntax->list (syntax (clause ...)))] + [check-preceding-exprs + (lambda (stop-before) + (let/ec k + (for-each (lambda (clause) + (if (eq? clause stop-before) + (k #t) + (syntax-case clause () + [(question answer) + (begin + (unless (and (identifier? (syntax question)) + (free-identifier=? (syntax question) + #'else)) + (local-expand-for-error (syntax question) 'expression null)) + (local-expand-for-error (syntax answer) 'expression null))]))) + clauses)))]) + (let ([checked-clauses + (map + (lambda (clause) + (syntax-case clause (else) + [(else answer) + (let ([lpos (memq clause clauses)]) + (when (not (null? (cdr lpos))) + (teach-syntax-error + 'cond + stx + clause + "found an `else' clause that isn't the last clause ~ + in its `cond' expression")) + (with-syntax ([new-test (syntax #t) ]) + (syntax/loc clause (new-test answer))))] + [(question answer) + (with-syntax ([verified + (syntax (verify-boolean question 'cond))]) + (syntax/loc clause (verified answer)))] + [() + (check-preceding-exprs clause) + (teach-syntax-error + 'cond + stx + clause + "expected a question--answer clause, but found an empty clause")] + [(question?) + (check-preceding-exprs clause) + (teach-syntax-error + 'cond + stx + clause + "expected a clause with a question and answer, but found a clause with only one part")] + [(question? answer? ...) + (check-preceding-exprs clause) + (let ([parts (syntax->list clause)]) + ;; to ensure the illusion of left-to-right checking, make sure + ;; the question and first answer (if any) are ok: + (unless (and (identifier? (car parts)) + (free-identifier=? (car parts) #'else)) + (local-expand-for-error (car parts) 'expression null)) + (unless (null? (cdr parts)) + (local-expand-for-error (cadr parts) 'expression null)) + ;; question and answer (if any) are ok, raise a count-based exception: + (teach-syntax-error* + 'cond + stx + parts + "expected a clause with one question and one answer, but found a clause with ~a parts" + (length parts)))] + [_else + (teach-syntax-error + 'cond + stx + clause + "expected a question--answer clause, but found ~a" + (something-else clause))])) + clauses)]) + ;; Add `else' clause for error (always): + (let ([clauses (append checked-clauses + (list + (with-syntax ([error-call (syntax/loc stx (error 'cond "all question results were false"))]) + (syntax [else error-call]))))]) + (with-syntax ([clauses clauses]) + (syntax/loc stx (cond . clauses))))))] + [_else (bad-use-error 'cond stx)])) + +(provide (rename-out [-cond cond])) + + + + + + +(define-syntax (-if stx) + (syntax-case stx () + [(_ test then else) + (with-syntax ([new-test (syntax (verify-boolean test 'if))]) + (syntax/loc stx + (if new-test + then + else)))] + [(_ . rest) + (let ([n (length (syntax->list (syntax rest)))]) + (teach-syntax-error + 'if + stx + #f + "expected one question expression and two answer expressions, but found ~a expression~a" + (if (zero? n) "no" n) + (if (= n 1) "" "s")))] + [_else (bad-use-error 'if stx)])) + +(provide (rename-out [-if if])) + + + + +;; Use to generate nicer error messages than direct pattern +;; matching. The `where' argument is an English description +;; of the portion of the larger expression where a single +;; sub-expression was expected. +(define-for-syntax (check-single-expression who where stx exprs will-bind) + (when (null? exprs) + (teach-syntax-error + who + stx + #f + "expected an expression ~a, but nothing's there" + where)) + (unless (null? (cdr exprs)) + ;; In case it's erroneous, to ensure left-to-right reading, let's + ;; try expanding the first expression. We have to use + ;; `will-bind' to avoid errors for unbound ids that will actually + ;; be bound. Since they're used as stopping points, we may miss + ;; some errors after all. It's worth a try, though. We also + ;; have to stop at advanced-set!, in case it's used with + ;; one of the identifiers in will-bind. + (when will-bind + (local-expand-for-error (car exprs) 'expression (cons #'advanced-set! + will-bind))) + ;; First expression seems ok, report an error for 2nd and later: + (teach-syntax-error + who + stx + (cadr exprs) + "expected only one expression ~a, but found ~a extra part" + where + (if (null? (cddr exprs)) + "one" + "at least one")))) + + + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; case +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax (-case stx) + (syntax-case stx () + [(_) + (teach-syntax-error + 'case + stx + #f + "expected an expression after `case', but nothing's there")] + [(_ expr) + (teach-syntax-error + 'case + stx + #f + "expected a choices--answer clause after the expression following `case', but nothing's there")] + [(_ v-expr clause ...) + (let ([clauses (syntax->list (syntax (clause ...)))]) + (for-each + (lambda (clause) + (syntax-case clause (else) + [(else answer ...) + (let ([lpos (memq clause clauses)]) + (when (not (null? (cdr lpos))) + (teach-syntax-error + 'case + stx + clause + "found an `else' clause that isn't the last clause ~ + in its `case' expression")) + (let ([answers (syntax->list (syntax (answer ...)))]) + (check-single-expression 'case + "for the answer in a case clause" + clause + answers + null)))] + [(choices answer ...) + (let ([choices (syntax choices)] + [answers (syntax->list (syntax (answer ...)))]) + (syntax-case choices () + [(elem ...) + (let ([elems (syntax->list (syntax (elem ...)))]) + (for-each (lambda (e) + (let ([v (syntax-e e)]) + (unless (or (number? v) + (symbol? v)) + (teach-syntax-error + 'case + stx + e + "expected a name (for a symbol) or a number as a choice value, but found ~a" + (something-else e))))) + elems))] + [_else (teach-syntax-error + 'case + stx + choices + "expected a parenthesized sequence of choice values, but found ~a" + (something-else choices))]) + (when (stx-null? choices) + (teach-syntax-error + 'case + stx + choices + "expected at least once choice in a parenthesized sequence of choice values, but nothing's there")) + (check-single-expression 'case + "for the answer in a `case' clause" + clause + answers + null))] + [() + (teach-syntax-error + 'case + stx + clause + "expected a choices--answer clause, but found an empty clause")] + [_else + (teach-syntax-error + 'case + stx + clause + "expected a choices--answer clause, but found ~a" + (something-else clause))])) + clauses) + ;; Add `else' clause for error, if necessary: + (let ([clauses (let loop ([clauses clauses]) + (cond + [(null? clauses) + (list + (syntax/loc stx + [else (error 'case "the expression matched none of the choices")]))] + [(syntax-case (car clauses) (else) + [(else . _) (syntax/loc (car clauses) (else . _))] + [_else #f]) + => + (lambda (x) (cons x (cdr clauses)))] + [else (cons (car clauses) (loop (cdr clauses)))]))]) + (with-syntax ([clauses clauses]) + (syntax/loc stx (case v-expr . clauses)))))] + [_else (bad-use-error 'case stx)])) + +(provide (rename-out [-case case])) + + + +#;(define-for-syntax (make-when-unless who target-stx) + (lambda (stx) + (syntax-case stx () + [(_ q expr ...) + (let ([exprs (syntax->list (syntax (expr ...)))]) + (check-single-expression who + (format "for the answer in `~a'" + who) + stx + exprs + null) + )] + [(_) + (teach-syntax-error + who + stx + #f + "expected a question expression after `~a', but nothing's there" + who)] + [_else + (bad-use-error who stx)]))) + + +;; FIXME: I'm seeing a bad error message when trying to use the functional +;; abstraction in teach.rkt to define the -when and -unless macros. +;; +;; The error message is: module-path-index-resolve: "self" index has +;; no resolution: # +;; As soon as the bug's resolved, refactor this back. +(define-syntax (-when stx) + (syntax-case stx () + [(_ q expr ...) + (let ([exprs (syntax->list (syntax (expr ...)))]) + (check-single-expression #'when + (format "for the answer in `~a'" + #'when) + stx + exprs + null) + (let ([result + (syntax/loc stx + (when (verify-boolean q 'when) expr ...))]) + result))] + [(_) + (teach-syntax-error + #'when + stx + #f + "expected a question expression after `~a', but nothing's there" + #'when)] + [_else + (bad-use-error #'when stx)])) +(define-syntax (-unless stx) + (syntax-case stx () + [(_ q expr ...) + (let ([exprs (syntax->list (syntax (expr ...)))]) + (check-single-expression #'unless + (format "for the answer in `~a'" + #'unless) + stx + exprs + null) + (let ([result + (syntax/loc stx + (unless (verify-boolean q 'unless) expr ...))]) + result))] + [(_) + (teach-syntax-error + #'unless + stx + #f + "expected a question expression after `~a', but nothing's there" + #'unless)] + [_else + (bad-use-error #'unless stx)])) + +(provide (rename-out [-when when] + [-unless unless])) + + + + + +;; ASL's member returns booleans. +(define (-member x L) + (cond + [(false? (member x L)) #f] + [else #t])) + +(provide (rename-out [-member member])) diff --git a/js-assembler/runtime-src/baselib-check.js b/js-assembler/runtime-src/baselib-check.js index 0513c0c..971642f 100644 --- a/js-assembler/runtime-src/baselib-check.js +++ b/js-assembler/runtime-src/baselib-check.js @@ -239,6 +239,17 @@ baselib.srclocs.isSrcloc, 'srcloc'); + var checkContinuationMarkSet = makeCheckArgumentType( + baselib.contmarks.isContinuationMarkSet, + 'continuation mark set'); + + var checkContinuationPromptTag = makeCheckArgumentType( + baselib.contmarks.isContinuationPromptTag, + 'continuation prompt tag'); + + var checkExn = makeCheckArgumentType( + baselib.exceptions.isExn, + 'exn'); ////////////////////////////////////////////////////////////////////// @@ -248,7 +259,6 @@ exports.makeCheckArgumentType = makeCheckArgumentType; exports.makeCheckParameterizedArgumentType = makeCheckParameterizedArgumentType; exports.makeCheckListofArgumentType = makeCheckListofArgumentType; - exports.checkOutputPort = checkOutputPort; exports.checkSymbol = checkSymbol; exports.checkString = checkString; @@ -275,5 +285,8 @@ exports.checkBoolean = checkBoolean; exports.checkPlaceholder = checkPlaceholder; exports.checkSrcloc = checkSrcloc; + exports.checkContinuationMarkSet = checkContinuationMarkSet; + exports.checkContinuationPromptTag = checkContinuationPromptTag; + exports.checkExn = checkExn; }(this.plt.baselib)); diff --git a/js-assembler/runtime-src/baselib-contmarks.js b/js-assembler/runtime-src/baselib-contmarks.js index 62d5dab..b406f70 100644 --- a/js-assembler/runtime-src/baselib-contmarks.js +++ b/js-assembler/runtime-src/baselib-contmarks.js @@ -41,8 +41,6 @@ return baselib.lists.makeList.apply(null, result); }; - - // Returns an approximate stack trace. // getContext: MACHINE -> (arrayof (U Procedure (Vector source line column position span))) ContinuationMarkSet.prototype.getContext = function(MACHINE) { @@ -71,21 +69,16 @@ return result; }; - - - - // A continuation prompt tag labels a prompt frame. var ContinuationPromptTag = function(name) { this.name = name; }; - - - - + var isContinuationMarkSet = baselib.makeClassPredicate(ContinuationMarkSet); + var isContinuationPromptTag = baselib.makeClassPredicate(ContinuationPromptTag); exports.ContinuationMarkSet = ContinuationMarkSet; exports.ContinuationPromptTag = ContinuationPromptTag; - + exports.isContinuationMarkSet = isContinuationMarkSet; + exports.isContinuationPromptTag = isContinuationPromptTag; }(this.plt.baselib)); \ No newline at end of file diff --git a/js-assembler/runtime-src/baselib-exceptions.js b/js-assembler/runtime-src/baselib-exceptions.js index 37a8d69..98df0a2 100644 --- a/js-assembler/runtime-src/baselib-exceptions.js +++ b/js-assembler/runtime-src/baselib-exceptions.js @@ -180,16 +180,6 @@ exceptions.RacketError = RacketError; exceptions.isRacketError = isRacketError; - - // exceptions.InternalError = InternalError; - // exceptions.internalError = function(v, contMarks) { return new InternalError(v, contMarks); }; - // exceptions.isInternalError = function(x) { return x instanceof InternalError; }; - - // exceptions.IncompleteExn = IncompleteExn; - // exceptions.makeIncompleteExn = function(constructor, msg, args) { return new IncompleteExn(constructor, msg, args); }; - // exceptions.isIncompleteExn = function(x) { return x instanceof IncompleteExn; }; - - exceptions.Exn = Exn; exceptions.makeExn = Exn.constructor; exceptions.isExn = Exn.predicate; diff --git a/js-assembler/runtime-src/baselib-primitives.js b/js-assembler/runtime-src/baselib-primitives.js index 9b29438..217cc18 100644 --- a/js-assembler/runtime-src/baselib-primitives.js +++ b/js-assembler/runtime-src/baselib-primitives.js @@ -84,6 +84,8 @@ var checkInspector = baselib.check.checkInspector; var checkPlaceholder = baselib.check.checkPlaceholder; var checkSrcloc = baselib.check.checkSrcloc; + var checkContinuationMarkSet = baselib.check.checkContinuationMarkSet; + var checkExn = baselib.check.checkExn; ////////////////////////////////////////////////////////////////////// @@ -162,7 +164,7 @@ installPrimitiveProcedure( - 'write-byte', + 'write-byte', makeList(1, 2), function (M) { var firstArg = checkByte(M, 'write-byte', 0); @@ -179,7 +181,7 @@ 'newline', makeList(0, 1), function (M) { var outputPort = M.params.currentOutputPort; - if (M.a === 1) { + if (M.a === 1) { outputPort = checkOutputPort(M, 'newline', 1); } outputPort.writeDomNode(M, toDomNode("\n", 'display')); @@ -225,7 +227,7 @@ args.push(M.e[M.e.length - 1 - i]); } result = baselib.format.format(formatString, args, 'format'); - outputPort = M.params.currentOutputPort; + outputPort = M.params.currentOutputPort; outputPort.writeDomNode(M, toDomNode(result, 'display')); return VOID; }); @@ -256,7 +258,7 @@ makeList(0, 1), function (M) { if (M.a === 1) { - M.params['currentPrint'] = + M.params['currentPrint'] = checkProcedure(M, 'current-print', 0); return VOID; } else { @@ -270,7 +272,7 @@ makeList(0, 1), function (M) { if (M.a === 1) { - M.params['currentOutputPort'] = + M.params['currentOutputPort'] = checkOutputPort(M, 'current-output-port', 0); return VOID; } else { @@ -285,7 +287,7 @@ makeList(0, 1), function (M) { if (M.a === 1) { - M.params['currentErrorPort'] = + M.params['currentErrorPort'] = checkOutputPort(M, 'current-output-port', 0); return VOID; } else { @@ -308,14 +310,13 @@ for (i = 1; i < M.a; i++) { secondArg = checkNumber(M, '=', i); if (! (baselib.numbers.equals(firstArg, secondArg))) { - return false; + return false; } } return true; }); - installPrimitiveProcedure( '=~', 3, @@ -324,7 +325,7 @@ var y = checkReal(M, '=~', 1); var range = checkNonNegativeReal(M, '=~', 2); return baselib.numbers.lessThanOrEqual( - baselib.numbers.abs(baselib.numbers.subtract(x, y)), + baselib.numbers.abs(baselib.numbers.subtract(x, y)), range); }); @@ -336,7 +337,7 @@ for (i = 1; i < M.a; i++) { secondArg = checkNumber(M, name, i); if (! (predicate(firstArg, secondArg))) { - return false; + return false; } firstArg = secondArg; } @@ -366,7 +367,7 @@ '>=', baselib.arity.makeArityAtLeast(2), makeChainingBinop(baselib.numbers.greaterThanOrEqual, '>=')); - + installPrimitiveProcedure( '+', @@ -376,12 +377,12 @@ var i = 0; for (i = 0; i < M.a; i++) { result = baselib.numbers.add( - result, + result, checkNumber(M, '+', i)); } return result; }); - + installPrimitiveProcedure( '*', @@ -391,7 +392,7 @@ var i = 0; for (i=0; i < M.a; i++) { result = baselib.numbers.multiply( - result, + result, checkNumber(M, '*', i)); } return result; @@ -401,20 +402,20 @@ '-', baselib.arity.makeArityAtLeast(1), function (M) { - if (M.a === 1) { + if (M.a === 1) { return baselib.numbers.subtract( - 0, + 0, checkNumber(M, '-', 0)); } var result = checkNumber(M, '-', 0), i; for (i = 1; i < M.a; i++) { result = baselib.numbers.subtract( - result, + result, checkNumber(M, '-', i)); } return result; }); - + installPrimitiveProcedure( '/', baselib.arity.makeArityAtLeast(1), @@ -427,7 +428,6 @@ } return result; }); - installPrimitiveProcedure( 'add1', @@ -558,7 +558,6 @@ return VOID; }); - installPrimitiveProcedure( 'not', 1, @@ -608,7 +607,6 @@ } return makeVector(arr.length, arr); }); - installPrimitiveProcedure( 'vector->list', @@ -623,7 +621,6 @@ return result; }); - installPrimitiveProcedure( 'list->vector', 1, @@ -1059,7 +1056,6 @@ - installPrimitiveProcedure( 'box', 1, @@ -1141,7 +1137,7 @@ // implementation of apply in the boostrapped-primitives.rkt, // since it provides nicer error handling. var applyImplementation = function (M) { - if(--M.callsBeforeTrampoline < 0) { + if(--M.callsBeforeTrampoline < 0) { throw applyImplementation; } var proc = checkProcedure(M, 'apply', 0); @@ -1180,7 +1176,7 @@ function (M) { return baselib.functions.isProcedure(M.e[M.e.length - 1]); }); - + installPrimitiveProcedure( 'procedure-arity-includes?', 2, @@ -1231,9 +1227,8 @@ return lst; } lst = lst.rest; - } + } }); - installPrimitiveProcedure( @@ -1370,7 +1365,6 @@ checkNumber(M, 'tan', 0)); }); - installPrimitiveProcedure( 'atan', @@ -1578,7 +1572,7 @@ return baselib.numbers.floor( checkReal(M, 'floor', 0)); }); - + installPrimitiveProcedure( 'ceiling', @@ -1754,6 +1748,18 @@ }); + installPrimitiveProcedure( + 'raise', + makeList(1, 2), + function(M) { + var v = M.e[M.e.length - 1]; + // At the moment, not using the continuation barrier yet. + // var withBarrier = M.e[M.e.length - 2]; + raise(M, v); + }); + + + installPrimitiveProcedure( 'raise-mismatch-error', 3, @@ -1790,7 +1796,94 @@ M.e[M.e.length - 1 - 2]); } }); - + + + + installPrimitiveProcedure( + 'make-exn', + 2, + function(M) { + var message = checkString(M, 'make-exn', 0); + var marks = checkContinuationMarkSet(M, 'make-exn', 1); + return baselib.exceptions.makeExn(message, marks); + }); + + + installPrimitiveProcedure( + 'make-exn:fail', + 2, + function(M) { + var message = checkString(M, 'make-exn:fail', 0); + var marks = checkContinuationMarkSet(M, 'make-exn:fail', 1); + return baselib.exceptions.makeExnFail(message, marks); + }); + + + installPrimitiveProcedure( + 'make-exn:fail:contract', + 2, + function(M) { + var message = checkString(M, 'make-exn:fail:contract', 0); + var marks = checkContinuationMarkSet(M, 'make-exn:fail:contract', 1); + return baselib.exceptions.makeExnFailContract(message, marks); + }); + + + installPrimitiveProcedure( + 'make-exn:fail:contract:arity', + 2, + function(M) { + var message = checkString(M, 'make-exn:fail:contract:arity', 0); + var marks = checkContinuationMarkSet(M, 'make-exn:fail:contract:arity', 1); + return baselib.exceptions.makeExnFailContractArity(message, marks); + }); + + installPrimitiveProcedure( + 'make-exn:fail:contract:variable', + 2, + function(M) { + var message = checkString(M, 'make-exn:fail:contract:variable', 0); + var marks = checkContinuationMarkSet(M, 'make-exn:fail:contract:variable', 1); + return baselib.exceptions.makeExnFailContractVariable(message, marks); + }); + + installPrimitiveProcedure( + 'make-exn:fail:contract:divide-by-zero', + 2, + function(M) { + var message = checkString(M, 'make-exn:fail:contract:divide-by-zero', 0); + var marks = checkContinuationMarkSet(M, 'make-exn:fail:contract:divide-by-zero', 1); + return baselib.exceptions.makeExnFailContractDivisionByZero(message, marks); + }); + + installPrimitiveProcedure( + 'exn-message', + 1, + function(M) { + var exn = checkExn(M, 'exn-message', 0); + return baselib.exceptions.exnMessage(exn); + }); + + installPrimitiveProcedure( + 'exn-continuation-marks', + 1, + function(M) { + var exn = checkExn(M, 'exn-continuation-marks', 0); + return baselib.exceptions.exnContMarks(exn); + }); + + + installPrimitiveProcedure( + 'current-continuation-marks', + makeList(0, 1), + function(M) { + var promptTag; + if (M.a === 1) { + promptTag = checkContinuationPromptTag(M, 'current-continuation-marks', 0); + } + return M.captureContinuationMarks(promptTag); + }); + diff --git a/js-assembler/runtime-src/runtime.js b/js-assembler/runtime-src/runtime.js index 94d584b..fd1cae4 100644 --- a/js-assembler/runtime-src/runtime.js +++ b/js-assembler/runtime-src/runtime.js @@ -375,12 +375,15 @@ }; - Machine.prototype.captureContinuationMarks = function() { + Machine.prototype.captureContinuationMarks = function(promptTag) { var kvLists = []; var i; var control = this.c; var tracedCalleeKey = getTracedCalleeKey(this); for (i = control.length-1; i >= 0; i--) { + if (control[i] instanceof PromptFrame && control[i].tag === promptTag) { + break; + } if (control[i].marks.length !== 0) { kvLists.push(control[i].marks); } diff --git a/lang/kernel.rkt b/lang/kernel.rkt index 659b2dc..8028b7d 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -195,7 +195,7 @@ displayln -;; current-continuation-marks + current-continuation-marks ;; continuation-mark-set? ;; continuation-mark-set->list @@ -221,21 +221,22 @@ random ;; sleep ;; (identity -identity) -;; raise - + +raise error raise-type-error raise-mismatch-error -;; make-exn -;; make-exn:fail -;; make-exn:fail:contract -;; make-exn:fail:contract:arity -;; make-exn:fail:contract:variable -;; make-exn:fail:contract:divide-by-zero +make-exn +make-exn:fail +make-exn:fail:contract +make-exn:fail:contract:arity +make-exn:fail:contract:variable +make-exn:fail:contract:divide-by-zero + +exn-message +exn-continuation-marks -;; exn-message -;; exn-continuation-marks ;; exn? ;; exn:fail? From 7cf22f4a1c149e6335e2a31353f7ca406eabfe86 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 19 Sep 2011 14:58:19 -0400 Subject: [PATCH 2/2] version of cs019 language in whalesong preliminary work --- cs019/cs019.rkt | 66 +++++++++++-------- js-assembler/runtime-src/baselib-contmarks.js | 4 ++ .../runtime-src/baselib-primitives.js | 6 +- js-assembler/runtime-src/runtime.js | 5 +- lang/kernel.rkt | 3 + 5 files changed, 55 insertions(+), 29 deletions(-) diff --git a/cs019/cs019.rkt b/cs019/cs019.rkt index 5ae0db9..4db0790 100644 --- a/cs019/cs019.rkt +++ b/cs019/cs019.rkt @@ -2,19 +2,25 @@ ;; Like the big whalesong language, but with additional ASL restrictions. -(require (for-syntax racket/base syntax/stx) - (only-in "../lang/whalesong.rkt")) +(require (for-syntax racket/base syntax/stx racket/match)) -(provide (except-out (all-from-out "../lang/whalesong.rkt") + +(require (prefix-in whalesong: "../lang/whalesong.rkt")) +(provide (except-out (filtered-out + (lambda (name) + (match name + [(regexp #rx"^whalesong:(.+)$" (list _ real-name)) + real-name] + [else + #f])) + (all-from-out "../lang/whalesong.rkt")) if cond case when unless member)) - - - + @@ -68,13 +74,19 @@ [else "something else"]))) ;; verify-boolean is inserted to check for boolean results: -(define (verify-boolean b where) - (if (or (eq? b #t) (eq? b #f)) - b - (raise - (make-exn:fail:contract - (format "~a: question result is not true or false: ~e" where b) - (current-continuation-marks))))) +(define-for-syntax (verify-boolean b where) + (with-syntax ([b b] + [where where]) + (quasisyntax/loc #'b + (let ([bv b]) + (if (or (eq? bv #t) (eq? bv #f)) + bv + #,(syntax/loc #'b + (whalesong:#%app raise + (make-exn:fail:contract + (format "~a: question result is not true or false: ~e" 'where bv) + (current-continuation-marks))))))))) + (define-syntax (-cond stx) (syntax-case stx () @@ -118,7 +130,7 @@ (syntax/loc clause (new-test answer))))] [(question answer) (with-syntax ([verified - (syntax (verify-boolean question 'cond))]) + (verify-boolean #'question 'cond)]) (syntax/loc clause (verified answer)))] [() (check-preceding-exprs clause) @@ -162,7 +174,7 @@ ;; Add `else' clause for error (always): (let ([clauses (append checked-clauses (list - (with-syntax ([error-call (syntax/loc stx (error 'cond "all question results were false"))]) + (with-syntax ([error-call (syntax/loc stx (whalesong:#%app raise (make-exn:fail:contract "cond: all question results were false" (current-continuation-marks))))]) (syntax [else error-call]))))]) (with-syntax ([clauses clauses]) (syntax/loc stx (cond . clauses))))))] @@ -178,7 +190,7 @@ (define-syntax (-if stx) (syntax-case stx () [(_ test then else) - (with-syntax ([new-test (syntax (verify-boolean test 'if))]) + (with-syntax ([new-test (verify-boolean #'test 'if)]) (syntax/loc stx (if new-test then @@ -327,7 +339,7 @@ [(null? clauses) (list (syntax/loc stx - [else (error 'case "the expression matched none of the choices")]))] + [else (whalesong:#%app raise (make-exn:fail:contract "case: the expression matched none of the choices" (current-continuation-marks)))]))] [(syntax-case (car clauses) (else) [(else . _) (syntax/loc (car clauses) (else . _))] [_else #f]) @@ -381,10 +393,11 @@ stx exprs null) - (let ([result - (syntax/loc stx - (when (verify-boolean q 'when) expr ...))]) - result))] + (with-syntax ([new-test (verify-boolean #'q 'when)]) + (let ([result + (syntax/loc stx + (when new-test expr ...))]) + result)))] [(_) (teach-syntax-error #'when @@ -404,10 +417,11 @@ stx exprs null) - (let ([result - (syntax/loc stx - (unless (verify-boolean q 'unless) expr ...))]) - result))] +< (with-syntax ([new-test (verify-boolean #'q 'when)]) + (let ([result + (syntax/loc stx + (unless new-test expr ...))]) + result)))] [(_) (teach-syntax-error #'unless @@ -428,7 +442,7 @@ ;; ASL's member returns booleans. (define (-member x L) (cond - [(false? (member x L)) #f] + [(eq? (member x L) #f) #f] [else #t])) (provide (rename-out [-member member])) diff --git a/js-assembler/runtime-src/baselib-contmarks.js b/js-assembler/runtime-src/baselib-contmarks.js index b406f70..8104e77 100644 --- a/js-assembler/runtime-src/baselib-contmarks.js +++ b/js-assembler/runtime-src/baselib-contmarks.js @@ -12,6 +12,10 @@ this.kvlists = kvlists; }; + ContinuationMarkSet.prototype.shift = function() { + this.kvlists.shift(); + }; + ContinuationMarkSet.prototype.toDomNode = function(cache) { var dom = document.createElement("span"); dom.appendChild(document.createTextNode('#')); diff --git a/js-assembler/runtime-src/baselib-primitives.js b/js-assembler/runtime-src/baselib-primitives.js index 217cc18..e200549 100644 --- a/js-assembler/runtime-src/baselib-primitives.js +++ b/js-assembler/runtime-src/baselib-primitives.js @@ -1881,7 +1881,11 @@ if (M.a === 1) { promptTag = checkContinuationPromptTag(M, 'current-continuation-marks', 0); } - return M.captureContinuationMarks(promptTag); + var contMarks = M.captureContinuationMarks(promptTag); + // The continuation marks shouldn't capture the record of the call to + // current-continuation-marks itself. + contMarks.shift(); + return contMarks; }); diff --git a/js-assembler/runtime-src/runtime.js b/js-assembler/runtime-src/runtime.js index fd1cae4..ad14bea 100644 --- a/js-assembler/runtime-src/runtime.js +++ b/js-assembler/runtime-src/runtime.js @@ -381,7 +381,8 @@ var control = this.c; var tracedCalleeKey = getTracedCalleeKey(this); for (i = control.length-1; i >= 0; i--) { - if (control[i] instanceof PromptFrame && control[i].tag === promptTag) { + if (promptTag !== null && + control[i] instanceof PromptFrame && control[i].tag === promptTag) { break; } if (control[i].marks.length !== 0) { @@ -393,7 +394,7 @@ control[i].p !== null) { kvLists.push([[tracedCalleeKey, control[i].p]]); } - } + } return new baselib.contmarks.ContinuationMarkSet(kvLists); }; diff --git a/lang/kernel.rkt b/lang/kernel.rkt index 8028b7d..52216a2 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -2,6 +2,7 @@ (require (prefix-in racket: (only-in racket/math pi sinh cosh sqr sgn conjugate)) (prefix-in racket: racket/base) + racket/provide racket/local (for-syntax racket/base) racket/stxparam @@ -121,6 +122,8 @@ except-out rename-out struct-out + filtered-out + define-syntax-rule define-syntax define-syntaxes