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

working on making the cs019 language for SK

Browse Source
This commit is contained in:
Danny Yoo 2011-09-19 14:02:00 -04:00
parent 07c36eb332
commit c96e12fac1
7 changed files with 587 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

432
cs019/cs019.rkt
View File

@ -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"))
(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: #<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)
(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]))

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

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

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

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;

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

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

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

23
lang/kernel.rkt
View File

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