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

version of cs019 language in whalesong preliminary work

Browse Source
This commit is contained in:
Danny Yoo 2011-09-19 14:58:19 -04:00
parent c96e12fac1
commit 7cf22f4a1c
5 changed files with 55 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
cs019/cs019.rkt
View File

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

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

@ -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('#<continuation-mark-set>'));

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

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

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

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

3
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
@ -121,6 +122,8 @@
except-out
rename-out
struct-out
filtered-out
define-syntax-rule
define-syntax
define-syntaxes