diff --git a/cs019/cs019-pre-base.rkt b/cs019/cs019-pre-base.rkt index efd6644..79ef55a 100644 --- a/cs019/cs019-pre-base.rkt +++ b/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) \ No newline at end of file +(define-syntax cs019-lambda advanced-lambda/proc) +(define-syntaxes (cs019-when cs019-unless) (values advanced-when/proc advanced-unless/proc)) \ No newline at end of file diff --git a/cs019/cs019.rkt b/cs019/cs019.rkt index 3fba19f..7cadbb4 100644 --- a/cs019/cs019.rkt +++ b/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: # -;; 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") diff --git a/cs019/teach.rkt b/cs019/teach.rkt index e1cdba0..b6557e2 100644 --- a/cs019/teach.rkt +++ b/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)))))