pulling when and unless from the original definitions

cs019/cs019-pre-base.rkt

@@ -1,9 +1,11 @@
 #lang s-exp "../lang/base.rkt"
 
 
-(require (for-syntax "teach.rkt"))
+(require (for-syntax "teach.rkt")
+         (for-syntax racket/base))
 
 (provide cs019-lambda)
 
 
 (define-syntax cs019-lambda advanced-lambda/proc)
+(define-syntaxes (cs019-when cs019-unless) (values advanced-when/proc advanced-unless/proc))

cs019/cs019.rkt

@@ -9,7 +9,9 @@
 
 
 (require "cs019-pre-base.rkt")
-(provide (rename-out [cs019-lambda lambda]))
+(provide (rename-out [cs019-lambda lambda]
+                     [cs019-when when]
+                     [cs019-unless unless]))
 
 
 (require (prefix-in whalesong: "../lang/whalesong.rkt"))
@@ -24,8 +26,6 @@
                      if
                      cond
                      case
-                     when
-                     unless
                      member
                      lambda)
 
@@ -385,90 +385,6 @@
 
 
 
-#;(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]))
-
-
-
-
 
 
 (define 1-LET "1-letter string")

cs019/teach.rkt

@@ -5,7 +5,9 @@
           racket/list)
 
 
-(provide advanced-lambda/proc)
+(provide advanced-lambda/proc
+         advanced-when/proc
+         advanced-unless/proc)
 
 
 
@@ -18,6 +20,17 @@
         (raise-syntax-error form msg stx))))
 
 
+(define (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))))
+
+
 
 (define (ensure-expression stx k)
   (if (memq (syntax-local-context) '(expression))
@@ -137,3 +150,47 @@
          "expected at least one variable (in parentheses) after lambda, but nothing's there")]
        [_else
         (bad-use-error 'lambda stx)]))))
+
+
+
+
+
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; when and unless (advanced)
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-values (advanced-when/proc advanced-unless/proc)
+  (let ([mk
+         (lambda (who target-stx)
+           (lambda (stx)
+             (ensure-expression
+              stx
+              (lambda ()
+                (syntax-case stx ()
+                  [(_)
+                   (teach-syntax-error
+                    who
+                    stx
+                    #f
+                    "expected a question and an answer, but nothing's there")]
+                  [(_ q)
+                   (teach-syntax-error
+                    who
+                    stx
+                    #'q
+                    "expected a question and an answer, but found only one part")]		      
+                  [(_ q a)
+                   (with-syntax ([who who]
+                                 [target target-stx])
+                     (syntax/loc stx (target (verify-boolean q 'who) a)))]
+                  [(_ . parts)
+                   (teach-syntax-error*
+                    who
+                    stx
+                    (syntax->list #'parts)
+                    "expected a question and an answer, but found ~a parts" (length (syntax->list #'parts)))]
+                  [_else
+                   (bad-use-error who stx)])))))])
+    (values (mk 'when (quote-syntax when))
+            (mk 'unless (quote-syntax unless)))))