Merge commit '7cf22f4a1c149e6335e2a31353f7ca406eabfe86'

Conflicts:

	cs019/cs019.rkt
	js-assembler/runtime-src/baselib-contmarks.js

cs019/cs019.rkt

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

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

js-assembler/runtime-src/baselib-contmarks.js

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

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;

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 {
@@ -283,7 +285,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 {
@@ -298,7 +300,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 {
@@ -321,14 +323,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,
@@ -337,7 +338,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);
         });
 
@@ -349,7 +350,7 @@
             for (i = 1; i < M.a; i++) {
                 secondArg = checkNumber(M, name, i);
                 if (! (predicate(firstArg, secondArg))) {
-                    return false; 
+                    return false;
                 }
                 firstArg = secondArg;
             }
@@ -379,7 +380,7 @@
         '>=',
         baselib.arity.makeArityAtLeast(2),
         makeChainingBinop(baselib.numbers.greaterThanOrEqual, '>='));
-    
+
 
     installPrimitiveProcedure(
         '+',
@@ -389,12 +390,12 @@
             var i = 0;
             for (i = 0; i < M.a; i++) {
                 result = baselib.numbers.add(
-                    result, 
+                    result,
                     checkNumber(M, '+', i));
             }
             return result;
         });
-    
+
 
     installPrimitiveProcedure(
         '*',
@@ -404,7 +405,7 @@
             var i = 0;
             for (i=0; i < M.a; i++) {
                 result = baselib.numbers.multiply(
-                    result, 
+                    result,
                     checkNumber(M, '*', i));
             }
             return result;
@@ -414,20 +415,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),
@@ -440,7 +441,6 @@
             }
             return result;
         });
-    
 
     installPrimitiveProcedure(
         'add1',
@@ -571,7 +571,6 @@
             return VOID;
         });
 
-    
     installPrimitiveProcedure(
         'not',
         1,
@@ -621,7 +620,6 @@
             }
             return makeVector(arr.length, arr);
         });
-    
 
     installPrimitiveProcedure(
         'vector->list',
@@ -636,7 +634,6 @@
             return result;
         });
 
-    
     installPrimitiveProcedure(
         'list->vector',
         1,
@@ -1072,7 +1069,6 @@
 
 
 
-    
     installPrimitiveProcedure(
         'box',
         1,
@@ -1154,7 +1150,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);
@@ -1193,7 +1189,7 @@
         function (M) {
             return baselib.functions.isProcedure(M.e[M.e.length - 1]);
         });
-    
+
     installPrimitiveProcedure(
         'procedure-arity-includes?',
         2,
@@ -1244,9 +1240,8 @@
                     return lst;
                 }
                 lst = lst.rest;
-            }   
+            }
         });
-    
 
 
     installPrimitiveProcedure(
@@ -1383,7 +1378,6 @@
                 checkNumber(M, 'tan', 0));
         });
 
-    
 
     installPrimitiveProcedure(
         'atan',
@@ -1591,7 +1585,7 @@
             return baselib.numbers.floor(
                 checkReal(M, 'floor', 0));
         });
-    
+
 
     installPrimitiveProcedure(
         'ceiling',
@@ -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,
@@ -1803,7 +1809,98 @@
                                        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);
+            }
+            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;
+        });
+        
 
 
 

js-assembler/runtime-src/runtime.js

@@ -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);
             }
@@ -396,7 +400,7 @@
                 control[i].p !== null) {
                 kvLists.push([[tracedCalleeKey, control[i].p]]);
             }
-        }     
+        }
         return new baselib.contmarks.ContinuationMarkSet(kvLists);
     };
     

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
@@ -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
-;;  make-exn:fail
+make-exn:fail
-;;  make-exn:fail:contract
+make-exn:fail:contract
-;;  make-exn:fail:contract:arity
+make-exn:fail:contract:arity
-;;  make-exn:fail:contract:variable
+make-exn:fail:contract:variable
-;;  make-exn:fail:contract:divide-by-zero
+make-exn:fail:contract:divide-by-zero
+
+exn-message
+exn-continuation-marks
 
-;;  exn-message
-;;  exn-continuation-marks
 
 ;;  exn?
 ;;  exn:fail?