version of cs019 language in whalesong preliminary work

cs019/cs019.rkt

@@ -2,10 +2,18 @@
 
 ;; Like the big whalesong language, but with additional ASL restrictions.
 
-(require (for-syntax racket/base syntax/stx)
+(require (for-syntax racket/base syntax/stx racket/match))
-         (only-in "../lang/whalesong.rkt"))
 
-(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
@@ -16,8 +24,6 @@
 
 
 
-
-
 (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.
@@ -68,13 +74,19 @@
       [else "something else"])))
 
 ;; verify-boolean is inserted to check for boolean results:
-(define (verify-boolean b where)
+(define-for-syntax (verify-boolean b where)
-  (if (or (eq? b #t) (eq? b #f))
+  (with-syntax ([b b]
-      b
+                [where where])
-      (raise
+    (quasisyntax/loc #'b
-       (make-exn:fail:contract
+      (let ([bv b])
-        (format "~a: question result is not true or false: ~e" where b)
+        (if (or (eq? bv #t) (eq? bv #f))
-        (current-continuation-marks)))))
+            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
+       (with-syntax ([new-test (verify-boolean #'q 'when)])
-              (syntax/loc stx 
+         (let ([result
-                (when (verify-boolean q 'when) expr ...))])
+                (syntax/loc stx 
-         result))]
+                  (when new-test expr ...))])
+           result)))]
     [(_)
      (teach-syntax-error
       #'when
@@ -404,10 +417,11 @@
                                 stx
                                 exprs
                                 null)
-       (let ([result
+<       (with-syntax ([new-test (verify-boolean #'q 'when)])
-              (syntax/loc stx 
+         (let ([result
-                (unless (verify-boolean q 'unless) expr ...))])
+                (syntax/loc stx 
-         result))]
+                  (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]))

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

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

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

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