suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge commit '7cf22f4a1c149e6335e2a31353f7ca406eabfe86'

Browse Source 
Conflicts:

	cs019/cs019.rkt
	js-assembler/runtime-src/baselib-contmarks.js
This commit is contained in:
Danny Yoo 2011-09-21 13:33:43 -04:00
commit cf9412710b
7 changed files with 618 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

449
cs019/cs019.rkt
View File

@ -1,7 +1,452 @@
#lang s-exp "../lang/whalesong.rkt"
#lang s-exp "../lang/kernel.rkt"
;; Like the big whalesong language, but with additional ASL restrictions.
(current-print-mode "constructor")
(provide (all-from-out "../lang/whalesong.rkt"))
(require (for-syntax racket/base syntax/stx racket/match))
(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))
(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-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 ()
[(_)
(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
(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 (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))))))]
[_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 (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 (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])
=>
(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: #<module-path-index>
;; 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)
(with-syntax ([new-test (verify-boolean #'q 'when)])
(let ([result
(syntax/loc stx
(when new-test 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)
(with-syntax ([new-test (verify-boolean #'q 'when)])
(let ([result
(syntax/loc stx
(unless new-test 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
[(eq? (member x L) #f) #f]
[else #t]))
(provide (rename-out [-member member]))

15
js-assembler/runtime-src/baselib-check.js
View File

@ -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));

18
js-assembler/runtime-src/baselib-contmarks.js
View File

@ -12,6 +12,11 @@
this.kvlists = kvlists;
};
ContinuationMarkSet.prototype.shift = function() {
this.kvlists.shift();
};
ContinuationMarkSet.prototype.toDomNode = function(params) {
var dom = document.createElement("span");
dom.appendChild(document.createTextNode('#<continuation-mark-set>'));
@ -41,8 +46,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,33 +74,30 @@
return result;
};
var isContinuationMarkSet = baselib.makeClassPredicate(ContinuationMarkSet);
// A continuation prompt tag labels a prompt frame.
var ContinuationPromptTag = function(name) {
this.name = name; // String
};
var isContinuationPromptTag = baselib.makeClassPredicate(ContinuationPromptTag);
var DEFAULT_CONTINUATION_PROMPT_TAG =
new ContinuationPromptTag("default-continuation-prompt-tag");
exports.ContinuationMarkSet = ContinuationMarkSet;
exports.isContinuationMarkSet = isContinuationMarkSet;
exports.ContinuationPromptTag = ContinuationPromptTag;
exports.isContinuationPromptTag = isContinuationPromptTag;
exports.DEFAULT_CONTINUATION_PROMPT_TAG = DEFAULT_CONTINUATION_PROMPT_TAG;
}(this.plt.baselib));

10
js-assembler/runtime-src/baselib-exceptions.js
View File

@ -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;

113
js-assembler/runtime-src/baselib-primitives.js
View File

@ -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;
//////////////////////////////////////////////////////////////////////
@ -328,7 +330,6 @@
});
installPrimitiveProcedure(
'=~',
3,
@ -441,7 +442,6 @@
return result;
});
installPrimitiveProcedure(
'add1',
1,
@ -571,7 +571,6 @@
return VOID;
});
installPrimitiveProcedure(
'not',
1,
@ -622,7 +621,6 @@
return makeVector(arr.length, arr);
});
installPrimitiveProcedure(
'vector->list',
1,
@ -636,7 +634,6 @@
return result;
});
installPrimitiveProcedure(
'list->vector',
1,
@ -1072,7 +1069,6 @@
installPrimitiveProcedure(
'box',
1,
@ -1248,7 +1244,6 @@
});
installPrimitiveProcedure(
'reverse',
1,
@ -1384,7 +1379,6 @@
});
installPrimitiveProcedure(
'atan',
makeList(1, 2),
@ -1767,6 +1761,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,
@ -1806,6 +1812,97 @@
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);
}
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;
});
installPrimitiveClosure(
'make-struct-type',

6
js-assembler/runtime-src/runtime.js
View File

@ -381,12 +381,16 @@
};
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 (promptTag !== null &&
control[i] instanceof PromptFrame && control[i].tag === promptTag) {
break;
}
if (control[i].marks.length !== 0) {
kvLists.push(control[i].marks);
}

24
lang/kernel.rkt
View File

@ -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
@ -130,6 +131,8 @@
except-out
rename-out
struct-out
filtered-out
define-syntax-rule
define-syntax
define-syntaxes
@ -207,7 +210,7 @@
displayln
;; current-continuation-marks
current-continuation-marks
;; continuation-mark-set?
;; continuation-mark-set->list
@ -233,21 +236,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?