#lang racket/base (require (for-template "../lang/base.rkt") (for-template "teach-runtime.rkt") "teachhelp.rkt" stepper/private/shared racket/list syntax/context syntax/kerncase syntax/stx) (provide advanced-define/proc advanced-lambda/proc advanced-when/proc advanced-unless/proc advanced-set!/proc advanced-set!-continue/proc advanced-case/proc intermediate-local/proc beginner-dots/proc) ;; 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))))) ;; A consistent pattern for stepper-skipto: (define (stepper-ignore-checker stx) (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car))) (define (make-name-inventer) ;; Normally we'd use (make-syntax-introducer) because gensyming makes ;; identifiers that play badly with exporting. But we don't have ;; to worry about exporting in the teaching languages, while we do ;; have to worry about mangled names. (lambda (id) (datum->syntax id (string->uninterned-symbol (symbol->string (syntax-e id))) id))) ;; Check context for a `define' before even trying to ;; expand (define-struct expanding-for-intermediate-local ()) ;; Raise a syntax error: (define (teach-syntax-error form stx detail msg . args) (let ([form (or form (first (flatten (syntax->datum stx))))] [msg (apply format msg args)]) (if detail (raise-syntax-error form msg stx detail) (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)) (k) (stepper-syntax-property #`(begin0 #,stx) 'stepper-skipto skipto/second))) (define (something-else/kw stx) (if (identifier? stx) "a keyword" (something-else stx))) ;; Use for messages "expected ..., found " (define (something-else v) (let ([v (syntax-e v)]) (cond [(number? v) "a number"] [(string? v) "a string"] [(list? v) "a part"] [(struct? v) "an image"] [else "something else"]))) ;; At the top level, wrap `defn' to first check for ;; existing definitions of the `names'. The `names' ;; argument is a syntax list of identifiers. ;; In a module context, just check the binding ;; at compile time. ;; In either context, if `assign?' is true, then ;; generate an unevaluated assignment that makes ;; the identifier mutable. (define (check-definitions-new who stx names defn assign) (cond [(eq? (syntax-local-context) 'top-level) (with-syntax ([defn defn] [who who]) (with-syntax ([(check ...) (map (lambda (name) (with-syntax ([name name]) ;; Make sure each check has the ;; source location of the original ;; expression: (syntax/loc stx (void) #;(check-top-level-not-defined 'who #'name)))) names)]) (stepper-syntax-property (syntax/loc stx (begin check ... defn)) 'stepper-skipto (cons 'syntax-e (let loop ([l names]) (if (null? l) `(syntax-e cdr car) (cons 'cdr (loop (cdr l)))))))))] [(memq (syntax-local-context) '(module module-begin)) (for-each (lambda (name) (let ([b (identifier-binding name)]) (when b (teach-syntax-error (syntax-e name) name #f "this name was defined previously and cannot be re-defined")))) names) (if assign (with-syntax ([(name ...) (if (eq? assign #t) names assign)] [made-up (gensym)] [defn defn]) (with-syntax ([made-up-defn (stepper-syntax-property (with-syntax ([set! (datum->syntax stx 'set!)]) (syntax (define made-up (lambda () (set! name 10) ...)))) 'stepper-skip-completely #t)]) (syntax/loc stx (begin made-up-defn ;; (define made-up (lambda () (advanced-set! name 10) ...)) defn)))) defn)] [else defn])) ;; Same as above, but for one name (define (check-definition-new who stx name defn assign) (check-definitions-new who stx (list name) defn assign)) (define (check-single-result-expr exprs where enclosing-expr will-bind) (check-single-expression where "for the function body" enclosing-expr exprs will-bind)) ;; 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 (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 (datum->syntax stx '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~a" where (sub1 (length exprs)) (if (> (length exprs) 2) "s" "")))) (define (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))) ;; The syntax error when a form's name doesn't follow a "(" (define (bad-use-error name stx) (teach-syntax-error name stx #f "expected an open parenthesis before ~a, but found none" name)) (define (check-defined-lambda rhs) (syntax-case rhs () [(lam . _) (and (identifier? #'lam) (or (free-identifier=? #'lam #'beginner-lambda) (free-identifier=? #'lam #'intermediate-pre-lambda))) (syntax-case rhs () [(lam arg-seq lexpr ...) (syntax-case (syntax arg-seq) () [(arg ...) #t][_else #f]) (let ([args (syntax->list (syntax arg-seq))]) (for-each (lambda (arg) (unless (identifier? arg) (teach-syntax-error 'lambda rhs arg "expected a variable, but found ~a" (something-else/kw arg)))) args) (when (null? args) (teach-syntax-error 'lambda rhs (syntax arg-seq) "expected at least one variable after lambda, but found none")) (let ([dup (check-duplicate-identifier args)]) (when dup (teach-syntax-error 'lambda rhs dup "found a variable that is used more than once: ~a" (syntax-e dup)))) (check-single-result-expr (syntax->list (syntax (lexpr ...))) #f rhs args) 'ok)] ;; Bad lambda because bad args: [(lam args . _) (teach-syntax-error 'lambda rhs (syntax args) "expected at least one variable (in parentheses) after lambda, but found ~a" (something-else (syntax args)))] ;; Bad lambda, no args: [(lam) (teach-syntax-error 'lambda rhs #f "expected at least one variable (in parentheses) after lambda, but nothing's there")] [_else 'ok])] [_else 'ok])) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; dots (.. and ... and .... and ..... and ......) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Syntax Identifier -> Expression ;; Produces an expression which raises an error reporting unfinished code. (define (dots-error stx name) (quasisyntax/loc stx (error (quote (unsyntax name)) "expected a finished expression, but found a template"))) ;; Expression -> Expression ;; Transforms unfinished code (... and the like) to code ;; raising an appropriate error. (define beginner-dots/proc (make-set!-transformer (lambda (stx) ;; this ensures that coverage happens; it lifts a constant ;; expression to the top level, but one that has the source location of the dots expression (syntax-local-lift-expression (datum->syntax #'here 1 stx)) (syntax-case stx (set!) [(set! form expr) (dots-error stx (syntax form))] [(form . rest) (dots-error stx (syntax form))] [form (dots-error stx stx)])))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; local ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (intermediate-local/proc stx) (ensure-expression stx (lambda () (syntax-case stx () [(_ (definition ...) . exprs) (let ([defns (syntax->list (syntax (definition ...)))] ;; The following context value lets teaching-language definition ;; forms know that it's ok to expand in this internal ;; definition context. [int-def-ctx (build-expand-context (make-expanding-for-intermediate-local))]) (let* ([partly-expand (lambda (d) (local-expand d int-def-ctx (kernel-form-identifier-list)))] [partly-expanded-defns (map partly-expand defns)] [flattened-defns (let loop ([l partly-expanded-defns][origs defns]) (apply append (map (lambda (d orig) (syntax-case d (begin define-values define-syntaxes) ;; we don't have to check for ill-formed `define-values' ;; or `define-syntaxes', because only macros can generate ;; them [(begin defn ...) (let ([l (map partly-expand (syntax->list (syntax (defn ...))))]) (loop l l))] [(define-values . _) (list d)] [(define-syntaxes . _) (list d)] [_else (teach-syntax-error 'local stx orig "expected a definition, but found ~a" (something-else orig))])) l origs)))] [val-defns (apply append (map (lambda (partly-expanded) (syntax-case partly-expanded (define-values) [(define-values (id ...) expr) (list partly-expanded)] [_else null])) flattened-defns))] [stx-defns (apply append (map (lambda (partly-expanded) (syntax-case partly-expanded (define-syntaxes) [(define-syntaxes (id ...) expr) (list partly-expanded)] [_else null])) flattened-defns))] [get-ids (lambda (l) (apply append (map (lambda (partly-expanded) (syntax-case partly-expanded () [(_ (id ...) expr) (syntax->list (syntax (id ...)))])) l)))] [val-ids (get-ids val-defns)] [stx-ids (get-ids stx-defns)]) (let ([dup (check-duplicate-identifier (append val-ids stx-ids))]) (when dup (teach-syntax-error 'local stx dup "~a was defined locally more than once" (syntax-e dup))) (let ([exprs (syntax->list (syntax exprs))]) (check-single-expression 'local "after the local definitions" stx exprs (append val-ids stx-ids))) (with-syntax ([((d-v (def-id ...) def-expr) ...) val-defns] [(stx-def ...) stx-defns]) (with-syntax ([(((tmp-id def-id/prop) ...) ...) ;; Generate tmp-ids that at least look like the defined ;; ids, for the purposes of error reporting, etc.: (map (lambda (def-ids) (map (lambda (def-id) (list (stepper-syntax-property (datum->syntax #f (string->uninterned-symbol (symbol->string (syntax-e def-id)))) 'stepper-orig-name def-id) (syntax-property def-id 'bind-as-variable #t))) (syntax->list def-ids))) (syntax->list (syntax ((def-id ...) ...))))]) (with-syntax ([(mapping ...) (let ([mappers (syntax->list (syntax ((define-syntaxes (def-id/prop ...) (values (make-undefined-check (quote-syntax check-not-undefined) (quote-syntax tmp-id)) ...)) ...)))]) (map syntax-track-origin mappers val-defns (syntax->list (syntax (d-v ...)))))]) (stepper-syntax-property (quasisyntax/loc stx (let () (#%stratified-body (define #,(gensym) 1) ; this ensures that the expansion of 'local' looks ; roughly the same, even if the local has no defs. mapping ... stx-def ... (define-values (tmp-id ...) def-expr) ... . exprs))) 'stepper-hint 'comes-from-local)))))))] [(_ def-non-seq . __) (teach-syntax-error 'local stx (syntax def-non-seq) "expected at least one definition (in square brackets) after local, but found ~a" (something-else (syntax def-non-seq)))] [(_) (teach-syntax-error 'local stx #f "expected at least one definition (in square brackets) after local, but nothing's there")] [_else (bad-use-error 'local stx)])))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; define (beginner) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (define/proc first-order? assign? stx lambda-stx) (define (wrap-func-definition name argc k) (wrap-func-definitions first-order? '(procedure) (list name) (list argc) (lambda (names) (k (car names))))) (define (check-function-defn-ok stx) (when first-order? (when (eq? 'top-level (syntax-local-context)) (teach-syntax-error 'define stx #f "function definitions are not allowed in the interactions window; ~ they must be in the definitions window")))) (unless (or (ok-definition-context) (identifier? stx)) (teach-syntax-error 'define stx #f "found a definition that is not at the top level")) (syntax-case stx () ;; Constant or lambda def: [(_ name expr) (identifier? (syntax name)) (let ([lam (syntax expr)]) (check-defined-lambda lam) (syntax-case* (syntax expr) (beginner-lambda) (lambda (a b) (free-identifier=? a lambda-stx)) ;; Well-formed lambda def: [(beginner-lambda arg-seq lexpr ...) (begin (check-function-defn-ok stx) (let-values ([(defn bind-names) (wrap-func-definition #'name (length (syntax->list #'arg-seq)) (lambda (name) (with-syntax ([name name]) (quasisyntax/loc stx (define name #,(stepper-syntax-property (syntax-track-origin #`(lambda arg-seq #,(stepper-syntax-property #`make-lambda-generative 'stepper-skip-completely #t) lexpr ...) lam (syntax-local-introduce (car (syntax-e lam)))) 'stepper-define-type 'lambda-define))))))]) (check-definition-new 'define stx #'name defn (and assign? bind-names))))] ;; Constant def [_else (check-definition-new 'define stx (syntax name) (quasisyntax/loc stx (define name expr)) (and assign? (list (syntax name))))]))] ;; Function definition: [(_ name-seq expr ...) (syntax-case (syntax name-seq) () [(name ...) #t][_else #f]) ;; name-seq is at least a sequence (let ([names (syntax->list (syntax name-seq))]) (check-function-defn-ok stx) (when (null? names) (teach-syntax-error 'define stx #f "expected a name for the function, but nothing's there")) (let loop ([names names][pos 0]) (unless (null? names) (unless (identifier? (car names)) (teach-syntax-error 'define stx (car names) "expected ~a, but found ~a" (cond [(zero? pos) "the name of the function"] [else "a variable"]) (something-else/kw (car names)))) (loop (cdr names) (add1 pos)))) (when (null? (cdr names)) (teach-syntax-error 'define stx (syntax name-seq) "expected at least one variable after the function name, but found none")) (let ([dup (check-duplicate-identifier (cdr names))]) (when dup (teach-syntax-error 'define stx dup "found a variable that is used more than once: ~a" (syntax-e dup)))) (check-single-result-expr (syntax->list (syntax (expr ...))) #f stx ;; can't local-expand function body, because ;; not all top-level defns are ready: #f) (let-values ([(defn bind-names) (wrap-func-definition (car (syntax-e #'name-seq)) (length (cdr (syntax->list #'name-seq))) (lambda (fn) (with-syntax ([fn fn] [args (cdr (syntax-e #'name-seq))]) (quasisyntax/loc stx (define fn #,(stepper-syntax-property (stepper-syntax-property ;; this is so signature blame can report a ;; position for the procedure (syntax/loc stx (lambda args expr ...)) 'stepper-define-type 'shortened-proc-define) 'stepper-proc-define-name #`fn))))))]) (check-definition-new 'define stx (car names) defn (and assign? bind-names))))] ;; Constant/lambda with too many or too few parts: [(_ name expr ...) (identifier? (syntax name)) (let ([exprs (syntax->list (syntax (expr ...)))]) (check-single-expression 'define (format "after the variable name ~a" (syntax-e (syntax name))) stx exprs ;; can't local-expand RHS, because ;; not all top-level defns are ready: #f))] ;; Bad name/header: [(_ non-name expr ...) (teach-syntax-error 'define stx (syntax non-name) "expected a variable name, or a function name and its variables (in parentheses), but found ~a" (something-else/kw (syntax non-name)))] ;; Missing name: [(_) (teach-syntax-error 'define stx #f "expected a variable name, or a function name and its variables (in parentheses), but nothing's there")] [_else (bad-use-error 'define stx)])) (define (wrap-func-definitions first-order? kinds names argcs k) (if first-order? (let ([name2s (map (make-name-inventer) names)]) (values (quasisyntax (begin #,@(map (lambda (name name2 kind argc) #`(define-syntax #,name (make-first-order-function '#,kind #,argc (quote-syntax #,name2) (quote-syntax #%app)))) names name2s kinds argcs) #,(k name2s))) name2s)) (values (k names) names))) (define (ok-definition-context) (let ([ctx (syntax-local-context)]) (or (memq ctx '(top-level module module-begin)) (and (pair? ctx) (expanding-for-intermediate-local? (car ctx)))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; define (advanced) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (advanced-define/proc stx) ;; Handle the case that doesn't fit into intermediate, then dispatch to ;; the common code that it also used by beginner/intermediate. (syntax-case stx () [(_ (name) expr) (and (identifier? (syntax name)) (ok-definition-context)) (check-definition-new 'define stx (syntax name) (syntax/loc stx (define (name) expr)) (list #'name))] [(_ (name) expr ...) (and (identifier? (syntax name)) (ok-definition-context)) (check-single-result-expr (syntax->list (syntax (expr ...))) #f stx (list #'name))] [(_ . rest) ;; Call transformer define/proc. ;; Note that we call the transformer instead of producing ;; new syntax object that is an `intermediate-define' form; ;; that's important for syntax errors, so that they ;; report `advanced-define' as the source. (define/proc #f #t stx #'beginner-lambda)] [_else (bad-use-error 'define stx)])) (define (advanced-lambda/proc stx) (ensure-expression stx (lambda () (syntax-case stx () [(_ (name ...) . exprs) (let ([names (syntax->list (syntax (name ...)))]) (for-each (lambda (name) (unless (identifier? name) (teach-syntax-error 'lambda stx name "expected a variable, but found ~a" (something-else/kw name)))) names) (let ([dup (check-duplicate-identifier names)]) (when dup (teach-syntax-error 'lambda stx dup "found a variable that is used more than once: ~a" (syntax-e dup)))) (check-single-expression 'lambda "for the function body" stx (syntax->list (syntax exprs)) names) (syntax/loc stx (lambda (name ...) . exprs)))] [(_ arg-non-seq . exprs) (teach-syntax-error 'lambda stx (syntax arg-non-seq) "expected at least one variable (in parentheses) after lambda, but found ~a" (something-else (syntax arg-non-seq)))] [(_) (teach-syntax-error 'lambda stx #f "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))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; set! (advanced) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; We disallow set!s on lambda-bound variables, which we recognize ;; as lexically-bound variables that are not bound to ;; set!-transformer syntax values. (define-values (advanced-set!/proc advanced-set!-continue/proc) (let ([proc (lambda (continuing?) (lambda (stx) (ensure-expression stx (lambda () (syntax-case stx () [(_ id expr ...) (identifier? (syntax id)) (let ([exprs (syntax->list (syntax (expr ...)))]) ;; Check that id isn't syntax, and not lexical. (when ((with-handlers ([exn:fail? (lambda (exn) (lambda () #t))]) ;; First try syntax: (let ([binding (syntax-local-value (syntax id))]) ;; If it's a transformer binding, then it can take care of itself... (if (set!-transformer? binding) (lambda () #f) ;; no lex check wanted (lambda () (teach-syntax-error 'set! stx (syntax id) "expected a variable after set!, but found a ~a" (syntax-e #'id))))))) ;; Now try lexical: (when (eq? 'lexical (identifier-binding (syntax id))) (teach-syntax-error 'set! stx (syntax id) "expected a mutable variable after set!, but found a variable that cannot be modified: ~a" (syntax-e #'id)))) ;; If we're in a module, we'd like to check here whether ;; the identier is bound, but we need to delay that check ;; in case the id is defined later in the module. So only ;; do this in continuing mode: (when continuing? (let ([binding (identifier-binding #'id)]) (cond [(and (not binding) (syntax-source-module #'id)) (teach-syntax-error #f #'id #f "this variable is not defined")] [(and (list? binding) (or (not (module-path-index? (car binding))) (let-values ([(path rel) (module-path-index-split (car binding))]) path))) (teach-syntax-error 'set! #'id #f "expected a mutable variable after set!, but found a variable that cannot be modified: ~a" (syntax-e #'id))]))) ;; Check the RHS (check-single-expression 'set! "for the new value" stx exprs null) (if continuing? (stepper-syntax-property (quasisyntax/loc stx (begin #,(datum->syntax #'here `(set! ,#'id ,@(syntax->list #'(expr ...))) stx) set!-result)) 'stepper-skipto (append skipto/cdr skipto/first)) (stepper-ignore-checker (quasisyntax/loc stx (#%app values #,(advanced-set!-continue/proc (syntax/loc stx (_ id expr ...))))))))] [(_ id . __) (teach-syntax-error 'set! stx (syntax id) "expected a variable after set!, but found ~a" (something-else (syntax id)))] [(_) (teach-syntax-error 'set! stx #f "expected a variable after set!, but nothing's there")] [_else (bad-use-error 'set! stx)])))))]) (values (proc #f) (proc #t)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; case ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (advanced-case/proc stx) (ensure-expression stx (lambda () (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 clause with at least one choice (in parentheses) and an answer after the expression, but nothing's there")] [(_ v-expr clause ...) (let ([clauses (syntax->list (syntax (clause ...)))]) (for-each (lambda (clause) (syntax-case clause (beginner-else) [(beginner-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 the 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 symbol (without its quote) or a number as a choice, but found ~a" (something-else e))))) elems))] [_else (teach-syntax-error 'case stx choices "expected at least one choice (in parentheses), but found ~a" (something-else choices))]) (when (stx-null? choices) (teach-syntax-error 'case stx choices "expected a symbol (without its quote) or a number as a choice, but nothing's there")) (check-single-expression 'case "for the answer in the case clause" clause answers null))] [() (teach-syntax-error 'case stx clause "expected a clause with at least one choice (in parentheses) and an answer, but found an empty part")] [_else (teach-syntax-error 'case stx clause "expected a clause with at least one choice (in parentheses) and an answer, 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 'cases "the expression matched none of the choices")]))] [(syntax-case (car clauses) (beginner-else) [(beginner-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)]))))