<commit_before>
;; Implements the syntactic forms for the HtDP teaching languages. The
;; reader-level aspects of the language (e.g., case-sensitivity) are
;; not implemented here, and the procedures are in a separate
;; module.

;; To a first approximation, this module is one big error-checking
;; routine. In other words, most of the syntax implementations are
;; straightforward, but error-checking is complex.

;; Error-message conventions:
;;  - Report errors, somewhat anthropomorphically, in terms of "expected"
;;    versus "found" syntax.
;;  - Report errors according to a left-to-right reading; e.g., the
;;    error in `(define 1 2 3)' is "expected an identifier, found 1",
;;    not "expected two parts after `define', but found three".
;;  - The error message should always explain what is wrong, not simply
;;    state a fact. For example, "f defined previously, so it cannot
;;    be re-defined here" is a good error message; in contrast, "found
;;    second definition of f here" doesn't say what's wrong with a second
;;    definition.

;; Left-to-right reporting sometimes requires an explicit expression
;; check before reporting some other error. For example, in the
;; expression (cond [true + 1 2]), the reported error should ideally
;; be for a misuse of "+", not that there are two extra parts in the
;; clause. This check requires local-expanding, so it doesn't work
;; when checking top-level forms like `define' (because not all of the
;; definitions are ready, yet). For other cases, ensure that the
;; expansion is in an expression position (not the top level) and use
;; the `local-expand-for-error' function instead of `local-expand' to
;; help declare that the expansion is merely for left-to-right error
;; reporting. As always, avoid using `local-expand' if there's no
;; error.

(module teach mzscheme
  (require (lib "etc.ss")
	   (lib "list.ss")
	   (lib "math.ss")
           "set-result.ss")
  (require-for-syntax "teachhelp.ss"
		      (lib "kerncase.ss" "syntax")
		      (lib "stx.ss" "syntax")
		      (lib "struct.ss" "syntax")
		      (lib "context.ss" "syntax")
		      (lib "include.ss")
                      (lib "shared.ss" "stepper" "private"))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; run-time helpers
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

  ;; Wrapped around uses of local-bound variables:
  (define (check-not-undefined name val)
    (if (eq? val undefined)
      (raise
       (make-exn:fail:contract:variable
        (format "local variable used before its definition: ~a" name)
        (current-continuation-marks)
        name))
      val))
  (define undefined (letrec ([x x]) x))

  ;; Wrapped around top-level definitions to disallow re-definition:
  (define (check-top-level-not-defined who id)
    (when (let ([b (identifier-binding id)])
	    ;; if it's not top-level, raise an exn
	    (if b
		#t
		;; At top-level, might be bound to syntax or value:
		(with-handlers ([exn:fail:contract:variable? (lambda (exn) #f)]
				[exn:fail:syntax? (lambda (exn) #t)])
		  (namespace-variable-value (syntax-e id) #t)
		  #t)))
      (error who "cannot redefine name: ~a" (syntax-e id))))

  ;; For quasiquote and shared:
  (require (rename "teachprims.ss" the-cons advanced-cons))
  (require (only   "teachprims.ss" cyclic-list?))

  ;; Referenced to ensure that evaluating `lambda' always
  ;; produces a new closure (instead of using a closure
  ;; that's allocated once)
  (define make-lambda-generative 5)
  
  ;; A consistent pattern for stepper-skipto:
  (define-for-syntax (stepper-ignore-checker stx)
    (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car)))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; syntax implementations
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define-syntax define-syntax-set/provide
    (lambda (stx)
      (syntax-case stx ()
	[(_ (id ...) defn ...)
	 (with-syntax ([(plain-id ...)
			(map (lambda (id)
			       (if (identifier? id)
				   id
				   (stx-car (stx-cdr id))))
			     (syntax->list (syntax (id ...))))]
		       [provided-identifiers
			(datum->syntax-object stx 'provided-identifiers)])
	   (syntax
	    (begin
	      (provide plain-id ...)
	      (define-syntax-set (id ...) 
		(define provided-identifiers (quote-syntax (id ...)))
		defn ...))))])))

  ;; The implementation of form X is defined below as X/proc. The
  ;; reason for this is to allow the implementation of Y to re-use the
  ;; implementation of X (expanding to a use of X would mangle syntax
  ;; error messages), while preserving the binding of X as the one for
  ;; the syntax definition (so that quasiquote can recognize unquote,
  ;; etc.).

  (define-syntax-set/provide (beginner-define
			      beginner-define-struct
			      beginner-lambda
			      beginner-app     beginner-app-continue
			      beginner-top     beginner-top-continue
			      beginner-cond
			      beginner-else
			      beginner-if
			      beginner-and
			      beginner-or
			      beginner-quote
                              beginner-require
                              beginner-dots
			      
			      intermediate-define
			      intermediate-define-struct
			      intermediate-local
			      intermediate-letrec
			      intermediate-let
			      intermediate-let*
			      intermediate-recur
			      intermediate-lambda
			      intermediate-app
			      intermediate-quote
			      intermediate-quasiquote
			      intermediate-unquote
			      intermediate-unquote-splicing
			      intermediate-time

			      advanced-define
			      advanced-lambda
			      advanced-app
			      advanced-set!  advanced-set!-continue
			      advanced-when
			      advanced-unless
			      advanced-define-struct
			      advanced-let
			      advanced-recur
			      advanced-begin
			      advanced-begin0
			      advanced-case
			      advanced-shared
			      advanced-delay)

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; compile-time helpers
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;; Raise a syntax error:
    (define (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 (binding-in-this-module? b)
      (and (list? b)
	   (module-path-index? (car b))
	   (let-values ([(path base) (module-path-index-split (car b))])
	     (and (not path) (not base)))))
    
    ;; The syntax error when a form's name doesn't follow a "("
    (define (bad-use-error name stx)
      (teach-syntax-error
       name
       stx
       #f
       "found a use of `~a' that does not follow an open parenthesis"
       name))

    ;; Use for messages "expected ..., found <something else>"
    (define (something-else v)
      (let ([v (syntax-e v)])
	(cond
	 [(number? v) "a number"]
	 [(string? v) "a string"]
	 [else "something else"])))
    
    (define (ordinal n)
      (cond
       [(or (<= 11 n 13)
	    (zero? (modulo n 10))
	    (<= 4 (modulo n 10) 9))
	(format "~ath" n)]
       [(= 1 (modulo n 10))
	(format "~ast" n)]
       [(= 2 (modulo n 10))
	(format "~and" n)]
       [(= 3 (modulo n 10))
	(format "~ard" n)]))

    ;; 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
                                    (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
			 'duplicate
			 name
			 #f
			 (if (binding-in-this-module? b)
			     "this name was defined previously and cannot be re-defined"
			     "this name has a built-in meaning and cannot be re-defined")))))
		  names)
        (if assign
            (with-syntax ([(name ...) (if (eq? assign #t)
                                          names
                                          assign)]
                          [make-up (gensym)]
                          [defn defn])
              (with-syntax ([made-up-defn (stepper-syntax-property 
                                           (syntax (define made-up (lambda () (advanced-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))

    ;; Check context for a `define' before even trying to
    ;; expand
    (define-struct expanding-for-intermediate-local ())
    (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 (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)))

    (define (ensure-expression stx k)
      (if (memq (syntax-local-context) '(expression))
	  (k)
	  (stepper-syntax-property #`(begin0 #,stx) 'stepper-skipto skipto/second)))

    ;; 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 #'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"))))

    (define (check-single-result-expr exprs where enclosing-expr will-bind)
      (check-single-expression where
			       "for the function body"
			       enclosing-expr
			       exprs
			       will-bind))

    (define keyword-list
      (append (syntax->list provided-identifiers)
	      (syntax->list (quote-syntax 
			     (#%datum
			      #%top
			      empty true false)))))

    (define (identifier/non-kw? stx)
      (and (identifier? stx)
	   (not (ormap (lambda (x) (module-identifier=? stx x))
		       keyword-list))))

    (define (something-else/kw stx)
      (if (identifier? stx)
	  "a keyword"
	  (something-else stx)))

    (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-object id 
			      (string->uninterned-symbol (symbol->string (syntax-e id)))
			      id)))

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

    (define (define/proc first-order? assign? 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/non-kw? (syntax name))
	 (let ([lam (syntax expr)])
	   (check-defined-lambda lam)
	   (syntax-case (syntax expr) (beginner-lambda)
	     ;; 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
                                         #`(lambda arg-seq 
                                             #,(stepper-syntax-property #`make-lambda-generative 
                                                                       'stepper-skip-completely #t) 
                                             lexpr ...)
                                         '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
	      names
	      "expected a function name for a definition, but the name is missing"))
	   (let loop ([names names][pos 0])
	     (unless (null? names)
	       (unless (identifier/non-kw? (car names))
		 (teach-syntax-error
		  'define
		  stx
		  (car names)
		  "expected a name for ~a, but found ~a"
		  (cond
		   [(zero? pos) "a function"]
		   [else (format "the function's ~a argument" (ordinal pos))])
		  (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 argument name after the function name, but found none"))
	   (let ([dup (check-duplicate-identifier (cdr names))])
	     (when dup
	       (teach-syntax-error
		'define
		stx
		dup
		"found an argument name that was 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
                                                                  #`(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/non-kw? (syntax name))
	 (let ([exprs (syntax->list (syntax (expr ...)))])
	   (check-single-expression 'define
				    (format "after the defined 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 function name, constant name, or function header for `define', but found ~a"
	  (something-else/kw (syntax non-name)))]
	;; Missing name:
	[(_)
	 (teach-syntax-error
	  'define
	  stx
	  #f
	  "expected a function name, constant name, or function header after `define', ~
         but nothing's there")]
	[_else
	 (bad-use-error 'define stx)]))

    (define (beginner-define/proc stx)
      (define/proc #t #f stx))

    (define (intermediate-define/proc stx)
      (define/proc #f #f stx))

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; lambda (beginner; only works with define)
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define (beginner-lambda/proc stx)
      (syntax-case stx ()
	[(_ . rest)
	 (teach-syntax-error
	  'lambda
	  stx
	  #f
	  "found a `lambda' expression that is not a function definition")]
	[_else
	 (bad-use-error 'lambda stx)]))


    (define (check-defined-lambda lam)
      (syntax-case lam (beginner-lambda)
	[(beginner-lambda 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/non-kw? arg)
			 (teach-syntax-error
			  'lambda
			  lam
			  arg
			  "expected a name for a function argument, but found ~a"
			  (something-else/kw arg))))
		     args)
	   (when (null? args)
	     (teach-syntax-error
	      'lambda
	      lam
	      (syntax arg-seq)
	      "expected at least one argument name in the sequence after `lambda', but found none"))
	   (let ([dup (check-duplicate-identifier args)])
	     (when dup
	       (teach-syntax-error
		'lambda
		lam
		dup
		"found an argument name that was used more than once: ~a"
		(syntax-e dup))))
	   (check-single-result-expr (syntax->list (syntax (lexpr ...)))
				     #f
				     lam
				     args)
	   'ok)]
	;; Bad lambda because bad args:
	[(beginner-lambda args . _)
	 (teach-syntax-error
	  'lambda
	  lam
	  (syntax args)
	  "expected a sequence of function arguments after `lambda', but found ~a"
	  (something-else (syntax args)))]
	;; Bad lambda, no args:
	[(beginner-lambda)
	 (teach-syntax-error
	  'lambda
	  lam
	  (syntax args)
	  "expected a sequence of function arguments after `lambda', but nothing's there")]
	[_else 'ok]))

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; define-struct (beginner)
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
    (define (do-define-struct stx first-order? setters? struct-info-is-useful?)
      
      (unless (or (ok-definition-context)
		  (identifier? stx))
	(teach-syntax-error
	 'define-struct
	 stx
	 #f
	 "found a definition that is not at the top level"))
      
      (syntax-case stx ()
	;; First, check for a struct name:
	[(_ name . __)
	 (not (identifier/non-kw? (syntax name)))
	 (teach-syntax-error
	  'define-struct
	  stx
	  (syntax name)
	  "expected a structure type name after `define-struct', but found ~a"
	  (something-else/kw (syntax name)))]
	;; Main case (`rest' is for nice error messages):
	[(_ name_ (field_ ...) . rest)
	 (let ([name (syntax name_)]
	       [fields (syntax->list (syntax (field_ ...)))]
	       [ht (make-hash-table)])
	   (for-each
	    (lambda (field)
	      (unless (identifier? field)
		(teach-syntax-error
		 'define-struct
		 stx
		 field
		 "expected a structure field name, found ~a"
		 (something-else field)))
	      (let ([sym (syntax-e field)])
		(when (hash-table-get ht sym (lambda () #f))
		  (teach-syntax-error
		   'define-struct
		   stx
		   field
		   "found a field name that was used more than once: ~a"
		   sym))
		(hash-table-put! ht sym #t)))
	    fields)
	   (let ([rest (syntax->list (syntax rest))])
	     (unless (null? rest)
	       (teach-syntax-error
		'define-struct
		stx
		(car rest)
		"expected nothing after the field name sequence in `define-struct', ~
               but found ~a extra part"
		(if (null? (cdr rest))
		    "one"
		    "at least one"))))
	   (let* ([to-define-names (let ([l (build-struct-names name fields #f (not setters?) stx)])
				     (if struct-info-is-useful?
					 ;; All names:
					 l
					 ;; Skip `struct:' name:
					 (cdr l)))]
		  [proc-names (if struct-info-is-useful?
				  (cdr to-define-names)
				  to-define-names)])
	     (with-syntax ([compile-info (if struct-info-is-useful?
					     (build-struct-expand-info name fields #f (not setters?) #t null null)
					     (syntax
					      (lambda (stx)
						(raise-syntax-error
						 #f
						 "expected an expression, but found a structure name"
						 stx))))])
               (let-values ([(defn0 bind-names)
                             (wrap-func-definitions 
			      first-order? 
			      (list* 'constructor 
				     'predicate
				     (map (lambda (x) 'selector) (cddr proc-names)))
			      proc-names
			      (list* (- (length proc-names) 2)
				     1
				     (map (lambda (x) 1) (cddr proc-names)))
			      (lambda (def-proc-names)
				(with-syntax ([(def-proc-name ...) def-proc-names]
					      [(proc-name ...) proc-names])
				  (stepper-syntax-property #`(define-values (def-proc-name ...)
						       (let ()
							 (define-struct name_ (field_ ...) (make-inspector))
							 (values proc-name ...)))
						   'stepper-define-struct-hint
						   stx))))])
                 (let ([defn
                         (quasisyntax/loc stx
                           (begin
                             #,(stepper-syntax-property #`(define-syntaxes (name_) compile-info)
                                                        'stepper-skip-completely
                                                        #t)
                             #,defn0))])
                   (check-definitions-new 'define-struct
                                          stx 
                                          (cons #'name_ to-define-names)
                                          defn
                                          (and setters? bind-names)))))))]
	[(_ name_ something . rest)
	 (teach-syntax-error
	  'define-struct
	  stx
	  (syntax something)
	  "expected a sequence of field names after the structure type name in `define-struct', ~
         but found ~a"
	  (something-else (syntax something)))]
	[(_ name_)
	 (teach-syntax-error
	  'define-struct
	  stx
	  (syntax something)
	  "expected a sequence of field names after the structure type name in `define-struct', ~
         but nothing's there")]
	[(_)
	 (teach-syntax-error
	  'define-struct
	  stx
	  #f
	  "expected a structure type name after `define-struct', but nothing's there")]
	[_else (bad-use-error 'define-struct stx)]))

    (define (beginner-define-struct/proc stx)
      (do-define-struct stx #t #f #t))

    (define (intermediate-define-struct/proc stx)
      (do-define-struct stx #f #f #t))

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; application (beginner and intermediate)
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;; For beginner:

    ;; #%app should never happen in beginner. Primitive operations and
    ;; defined functions turn into syntax that handle application
    ;; forms.  The only vaguely legitimate application would involve a
    ;; poorly implemented teachpack that exports functions instead of
    ;; primitive operators. Also, #%app is unavoidable in the REPL.

    ;; An #%app might happen "temporarily" if it appears at the top
    ;; level before the corresponding function definition. To provide
    ;; a good error message, we need to wait, and that's what
    ;; beginner-app-delay does.

    ;; For intermediate:

    ;; This application form disallows rator expressions that aren't
    ;; top-level identifiers or of the form `(check-not-undefined ...)'.

    ;; The latter is probably surprising. It turns out that every use of
    ;; a `local'-bound identifier gets converted to an undefined check,
    ;; and the call to `check-not-undefined' can't be forged by the
    ;; programmer. So the pattern-match effectively recognizes uses of
    ;; `local'-bound identifiers, which are legal as rator
    ;; expressions. (`let' and `letrec' get converted to `local'.)

    (define-values (beginner-app/proc intermediate-app/proc)
      (let ([mk-app
	     (lambda (lex-ok?)
	       (lambda (stx)
		 (syntax-case stx ()
		   [(_ rator rand ...)
		    (let* ([fun (syntax rator)]
			   [undef-check? (syntax-case fun (check-not-undefined)
					   [(check-not-undefined id)
					    #t]
					   [_else #f])]
			   [binding (and (identifier? fun)
					 (identifier-binding fun))]
			   [lex? (eq? 'lexical binding)]
			   [bad-app (lambda (what)
				      (teach-syntax-error
				       '|function call|
					 stx
					 fun
					 "expected a ~a after an open parenthesis, but found ~a"
					 (if lex-ok?
					     "name"
					     "defined name or a primitive operation name")
					 what))])
		      (unless (and (identifier? fun) (or lex-ok? undef-check? (not lex?)))
			(bad-app (if lex?
				     "a function argument name"
				     (something-else fun))))
		      ;; The following check disallows calling thunks.
		      ;; It's disabled because we need to allow calls to
		      ;; primitive thunks.
		      '(when (null? (syntax->list (syntax (rand ...))))
			 (teach-syntax-error
			  '|function call|
			    stx
			    #f
			    "expected an argument after the function name for a function call, ~
                             but nothing's there"))
		      (cond
		       [(and (not lex-ok?) (binding-in-this-module? binding))
			;; An application of something defined as a constant
			(bad-app "something else")]
		       [(or lex-ok? (and binding (not (binding-in-this-module? binding))))
			(syntax/loc stx (#%app rator rand ...))]
		       [else
			;; We don't know what rator is, yet, and it might be local:
			(quasisyntax/loc 
			 stx 
			 (#%app values #,(quasisyntax/loc
					  stx
					  (beginner-app-continue rator rand ...))))]))]
		   [(_)
		    (teach-syntax-error
		     '|function call|
		       stx
		       #f
		       (format
			"expected a ~a after an open parenthesis, but nothing's there"
			(if lex-ok?
			    "name"
			    "defined name or a primitive operation name")))]
		   [_else (bad-use-error '#%app stx)])))])
	(values (mk-app #f) (mk-app #t))))

    (define (beginner-app-continue/proc stx)
      (syntax-case stx ()
	[(_ rator rand ...)
	 (let* ([fun #'rator]
		[binding (identifier-binding fun)])
	   (if binding
	       ;; Now defined in the module:
	       (if (set!-transformer? (syntax-local-value fun (lambda () #f)))
		   ;; Something that takes care of itself:
		   (syntax/loc stx (rator rand ...))
		   ;; Something for which we probably need to report an error,
		   ;;  but let beginner-app take care of it:
		   (syntax/loc stx (beginner-app rator rand ...)))
	       ;; Something undefined; let beginner-top take care of it:
	       (syntax/loc stx (#%app rator rand ...))))]))

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; top-level variables (beginner)
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;; Report errors for undefined names (but only in modules)

    (define (beginner-top/proc stx)
      (syntax-case stx ()
        [(_ . id)
	 ;; If we're in a module, we'll need to check that the name
	 ;;  is bound....
	 (if (and (not (identifier-binding #'id))
		  (syntax-source-module #'id))
	     ;; ... but it might be defined later in the module, so
	     ;; delay the check.
             (stepper-ignore-checker 
              (syntax/loc stx (#%app values (beginner-top-continue id))))
	     (syntax/loc stx (#%top . id)))]))

    (define (beginner-top-continue/proc stx)
      (syntax-case stx ()
        [(_ id)
	 ;; If there's still no binding, it's an "unknown name" error.
	 (if (not (identifier-binding #'id))
	     (teach-syntax-error
	      'unknown
	      #'id
	      #f
	      "name is not defined, not a parameter, and not a primitive name")
	     ;; Don't use #%top here; id might have become bound to something
	     ;;  that isn't a value.
	     #'id)]))

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; cond
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define (beginner-cond/proc stx)
      (ensure-expression
       stx
       (lambda ()
	 (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))
							  (module-identifier=? (syntax question) #'beginner-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 (beginner-else)
			  [(beginner-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 (stepper-syntax-property (syntax #t) 'stepper-else #t)])
			       (syntax/loc clause (new-test answer))))]
			  [(question answer)
			   (with-syntax ([verified (stepper-ignore-checker (syntax (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))
					  (module-identifier=? (car parts) #'beginner-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
			      clause
			      "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 <commit_msg>change beginner-cond error to highlight individual cond-clause elements when the wrong number are present<commit_after>
;; Implements the syntactic forms for the HtDP teaching languages. The
;; reader-level aspects of the language (e.g., case-sensitivity) are
;; not implemented here, and the procedures are in a separate
;; module.

;; To a first approximation, this module is one big error-checking
;; routine. In other words, most of the syntax implementations are
;; straightforward, but error-checking is complex.

;; Error-message conventions:
;;  - Report errors, somewhat anthropomorphically, in terms of "expected"
;;    versus "found" syntax.
;;  - Report errors according to a left-to-right reading; e.g., the
;;    error in `(define 1 2 3)' is "expected an identifier, found 1",
;;    not "expected two parts after `define', but found three".
;;  - The error message should always explain what is wrong, not simply
;;    state a fact. For example, "f defined previously, so it cannot
;;    be re-defined here" is a good error message; in contrast, "found
;;    second definition of f here" doesn't say what's wrong with a second
;;    definition.

;; Left-to-right reporting sometimes requires an explicit expression
;; check before reporting some other error. For example, in the
;; expression (cond [true + 1 2]), the reported error should ideally
;; be for a misuse of "+", not that there are two extra parts in the
;; clause. This check requires local-expanding, so it doesn't work
;; when checking top-level forms like `define' (because not all of the
;; definitions are ready, yet). For other cases, ensure that the
;; expansion is in an expression position (not the top level) and use
;; the `local-expand-for-error' function instead of `local-expand' to
;; help declare that the expansion is merely for left-to-right error
;; reporting. As always, avoid using `local-expand' if there's no
;; error.

(module teach mzscheme
  (require (lib "etc.ss")
	   (lib "list.ss")
	   (lib "math.ss")
           "set-result.ss")
  (require-for-syntax "teachhelp.ss"
		      (lib "kerncase.ss" "syntax")
		      (lib "stx.ss" "syntax")
		      (lib "struct.ss" "syntax")
		      (lib "context.ss" "syntax")
		      (lib "include.ss")
                      (lib "shared.ss" "stepper" "private"))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; run-time helpers
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

  ;; Wrapped around uses of local-bound variables:
  (define (check-not-undefined name val)
    (if (eq? val undefined)
      (raise
       (make-exn:fail:contract:variable
        (format "local variable used before its definition: ~a" name)
        (current-continuation-marks)
        name))
      val))
  (define undefined (letrec ([x x]) x))

  ;; Wrapped around top-level definitions to disallow re-definition:
  (define (check-top-level-not-defined who id)
    (when (let ([b (identifier-binding id)])
	    ;; if it's not top-level, raise an exn
	    (if b
		#t
		;; At top-level, might be bound to syntax or value:
		(with-handlers ([exn:fail:contract:variable? (lambda (exn) #f)]
				[exn:fail:syntax? (lambda (exn) #t)])
		  (namespace-variable-value (syntax-e id) #t)
		  #t)))
      (error who "cannot redefine name: ~a" (syntax-e id))))

  ;; For quasiquote and shared:
  (require (rename "teachprims.ss" the-cons advanced-cons))
  (require (only   "teachprims.ss" cyclic-list?))

  ;; Referenced to ensure that evaluating `lambda' always
  ;; produces a new closure (instead of using a closure
  ;; that's allocated once)
  (define make-lambda-generative 5)
  
  ;; A consistent pattern for stepper-skipto:
  (define-for-syntax (stepper-ignore-checker stx)
    (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car)))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; syntax implementations
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define-syntax define-syntax-set/provide
    (lambda (stx)
      (syntax-case stx ()
	[(_ (id ...) defn ...)
	 (with-syntax ([(plain-id ...)
			(map (lambda (id)
			       (if (identifier? id)
				   id
				   (stx-car (stx-cdr id))))
			     (syntax->list (syntax (id ...))))]
		       [provided-identifiers
			(datum->syntax-object stx 'provided-identifiers)])
	   (syntax
	    (begin
	      (provide plain-id ...)
	      (define-syntax-set (id ...) 
		(define provided-identifiers (quote-syntax (id ...)))
		defn ...))))])))

  ;; The implementation of form X is defined below as X/proc. The
  ;; reason for this is to allow the implementation of Y to re-use the
  ;; implementation of X (expanding to a use of X would mangle syntax
  ;; error messages), while preserving the binding of X as the one for
  ;; the syntax definition (so that quasiquote can recognize unquote,
  ;; etc.).

  (define-syntax-set/provide (beginner-define
			      beginner-define-struct
			      beginner-lambda
			      beginner-app     beginner-app-continue
			      beginner-top     beginner-top-continue
			      beginner-cond
			      beginner-else
			      beginner-if
			      beginner-and
			      beginner-or
			      beginner-quote
                              beginner-require
                              beginner-dots
			      
			      intermediate-define
			      intermediate-define-struct
			      intermediate-local
			      intermediate-letrec
			      intermediate-let
			      intermediate-let*
			      intermediate-recur
			      intermediate-lambda
			      intermediate-app
			      intermediate-quote
			      intermediate-quasiquote
			      intermediate-unquote
			      intermediate-unquote-splicing
			      intermediate-time

			      advanced-define
			      advanced-lambda
			      advanced-app
			      advanced-set!  advanced-set!-continue
			      advanced-when
			      advanced-unless
			      advanced-define-struct
			      advanced-let
			      advanced-recur
			      advanced-begin
			      advanced-begin0
			      advanced-case
			      advanced-shared
			      advanced-delay)

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; compile-time helpers
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;; Raise a syntax error:
    (define (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 (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)
          (apply list-immutable details)))))
    
    (define (binding-in-this-module? b)
      (and (list? b)
	   (module-path-index? (car b))
	   (let-values ([(path base) (module-path-index-split (car b))])
	     (and (not path) (not base)))))
    
    ;; The syntax error when a form's name doesn't follow a "("
    (define (bad-use-error name stx)
      (teach-syntax-error
       name
       stx
       #f
       "found a use of `~a' that does not follow an open parenthesis"
       name))

    ;; Use for messages "expected ..., found <something else>"
    (define (something-else v)
      (let ([v (syntax-e v)])
	(cond
	 [(number? v) "a number"]
	 [(string? v) "a string"]
	 [else "something else"])))
    
    (define (ordinal n)
      (cond
       [(or (<= 11 n 13)
	    (zero? (modulo n 10))
	    (<= 4 (modulo n 10) 9))
	(format "~ath" n)]
       [(= 1 (modulo n 10))
	(format "~ast" n)]
       [(= 2 (modulo n 10))
	(format "~and" n)]
       [(= 3 (modulo n 10))
	(format "~ard" n)]))

    ;; 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
                                    (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
			 'duplicate
			 name
			 #f
			 (if (binding-in-this-module? b)
			     "this name was defined previously and cannot be re-defined"
			     "this name has a built-in meaning and cannot be re-defined")))))
		  names)
        (if assign
            (with-syntax ([(name ...) (if (eq? assign #t)
                                          names
                                          assign)]
                          [make-up (gensym)]
                          [defn defn])
              (with-syntax ([made-up-defn (stepper-syntax-property 
                                           (syntax (define made-up (lambda () (advanced-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))

    ;; Check context for a `define' before even trying to
    ;; expand
    (define-struct expanding-for-intermediate-local ())
    (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 (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)))

    (define (ensure-expression stx k)
      (if (memq (syntax-local-context) '(expression))
	  (k)
	  (stepper-syntax-property #`(begin0 #,stx) 'stepper-skipto skipto/second)))

    ;; 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 #'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"))))

    (define (check-single-result-expr exprs where enclosing-expr will-bind)
      (check-single-expression where
			       "for the function body"
			       enclosing-expr
			       exprs
			       will-bind))

    (define keyword-list
      (append (syntax->list provided-identifiers)
	      (syntax->list (quote-syntax 
			     (#%datum
			      #%top
			      empty true false)))))

    (define (identifier/non-kw? stx)
      (and (identifier? stx)
	   (not (ormap (lambda (x) (module-identifier=? stx x))
		       keyword-list))))

    (define (something-else/kw stx)
      (if (identifier? stx)
	  "a keyword"
	  (something-else stx)))

    (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-object id 
			      (string->uninterned-symbol (symbol->string (syntax-e id)))
			      id)))

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

    (define (define/proc first-order? assign? 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/non-kw? (syntax name))
	 (let ([lam (syntax expr)])
	   (check-defined-lambda lam)
	   (syntax-case (syntax expr) (beginner-lambda)
	     ;; 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
                                         #`(lambda arg-seq 
                                             #,(stepper-syntax-property #`make-lambda-generative 
                                                                       'stepper-skip-completely #t) 
                                             lexpr ...)
                                         '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
	      names
	      "expected a function name for a definition, but the name is missing"))
	   (let loop ([names names][pos 0])
	     (unless (null? names)
	       (unless (identifier/non-kw? (car names))
		 (teach-syntax-error
		  'define
		  stx
		  (car names)
		  "expected a name for ~a, but found ~a"
		  (cond
		   [(zero? pos) "a function"]
		   [else (format "the function's ~a argument" (ordinal pos))])
		  (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 argument name after the function name, but found none"))
	   (let ([dup (check-duplicate-identifier (cdr names))])
	     (when dup
	       (teach-syntax-error
		'define
		stx
		dup
		"found an argument name that was 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
                                                                  #`(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/non-kw? (syntax name))
	 (let ([exprs (syntax->list (syntax (expr ...)))])
	   (check-single-expression 'define
				    (format "after the defined 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 function name, constant name, or function header for `define', but found ~a"
	  (something-else/kw (syntax non-name)))]
	;; Missing name:
	[(_)
	 (teach-syntax-error
	  'define
	  stx
	  #f
	  "expected a function name, constant name, or function header after `define', ~
         but nothing's there")]
	[_else
	 (bad-use-error 'define stx)]))

    (define (beginner-define/proc stx)
      (define/proc #t #f stx))

    (define (intermediate-define/proc stx)
      (define/proc #f #f stx))

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; lambda (beginner; only works with define)
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define (beginner-lambda/proc stx)
      (syntax-case stx ()
	[(_ . rest)
	 (teach-syntax-error
	  'lambda
	  stx
	  #f
	  "found a `lambda' expression that is not a function definition")]
	[_else
	 (bad-use-error 'lambda stx)]))


    (define (check-defined-lambda lam)
      (syntax-case lam (beginner-lambda)
	[(beginner-lambda 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/non-kw? arg)
			 (teach-syntax-error
			  'lambda
			  lam
			  arg
			  "expected a name for a function argument, but found ~a"
			  (something-else/kw arg))))
		     args)
	   (when (null? args)
	     (teach-syntax-error
	      'lambda
	      lam
	      (syntax arg-seq)
	      "expected at least one argument name in the sequence after `lambda', but found none"))
	   (let ([dup (check-duplicate-identifier args)])
	     (when dup
	       (teach-syntax-error
		'lambda
		lam
		dup
		"found an argument name that was used more than once: ~a"
		(syntax-e dup))))
	   (check-single-result-expr (syntax->list (syntax (lexpr ...)))
				     #f
				     lam
				     args)
	   'ok)]
	;; Bad lambda because bad args:
	[(beginner-lambda args . _)
	 (teach-syntax-error
	  'lambda
	  lam
	  (syntax args)
	  "expected a sequence of function arguments after `lambda', but found ~a"
	  (something-else (syntax args)))]
	;; Bad lambda, no args:
	[(beginner-lambda)
	 (teach-syntax-error
	  'lambda
	  lam
	  (syntax args)
	  "expected a sequence of function arguments after `lambda', but nothing's there")]
	[_else 'ok]))

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; define-struct (beginner)
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
    (define (do-define-struct stx first-order? setters? struct-info-is-useful?)
      
      (unless (or (ok-definition-context)
		  (identifier? stx))
	(teach-syntax-error
	 'define-struct
	 stx
	 #f
	 "found a definition that is not at the top level"))
      
      (syntax-case stx ()
	;; First, check for a struct name:
	[(_ name . __)
	 (not (identifier/non-kw? (syntax name)))
	 (teach-syntax-error
	  'define-struct
	  stx
	  (syntax name)
	  "expected a structure type name after `define-struct', but found ~a"
	  (something-else/kw (syntax name)))]
	;; Main case (`rest' is for nice error messages):
	[(_ name_ (field_ ...) . rest)
	 (let ([name (syntax name_)]
	       [fields (syntax->list (syntax (field_ ...)))]
	       [ht (make-hash-table)])
	   (for-each
	    (lambda (field)
	      (unless (identifier? field)
		(teach-syntax-error
		 'define-struct
		 stx
		 field
		 "expected a structure field name, found ~a"
		 (something-else field)))
	      (let ([sym (syntax-e field)])
		(when (hash-table-get ht sym (lambda () #f))
		  (teach-syntax-error
		   'define-struct
		   stx
		   field
		   "found a field name that was used more than once: ~a"
		   sym))
		(hash-table-put! ht sym #t)))
	    fields)
	   (let ([rest (syntax->list (syntax rest))])
	     (unless (null? rest)
	       (teach-syntax-error
		'define-struct
		stx
		(car rest)
		"expected nothing after the field name sequence in `define-struct', ~
               but found ~a extra part"
		(if (null? (cdr rest))
		    "one"
		    "at least one"))))
	   (let* ([to-define-names (let ([l (build-struct-names name fields #f (not setters?) stx)])
				     (if struct-info-is-useful?
					 ;; All names:
					 l
					 ;; Skip `struct:' name:
					 (cdr l)))]
		  [proc-names (if struct-info-is-useful?
				  (cdr to-define-names)
				  to-define-names)])
	     (with-syntax ([compile-info (if struct-info-is-useful?
					     (build-struct-expand-info name fields #f (not setters?) #t null null)
					     (syntax
					      (lambda (stx)
						(raise-syntax-error
						 #f
						 "expected an expression, but found a structure name"
						 stx))))])
               (let-values ([(defn0 bind-names)
                             (wrap-func-definitions 
			      first-order? 
			      (list* 'constructor 
				     'predicate
				     (map (lambda (x) 'selector) (cddr proc-names)))
			      proc-names
			      (list* (- (length proc-names) 2)
				     1
				     (map (lambda (x) 1) (cddr proc-names)))
			      (lambda (def-proc-names)
				(with-syntax ([(def-proc-name ...) def-proc-names]
					      [(proc-name ...) proc-names])
				  (stepper-syntax-property #`(define-values (def-proc-name ...)
						       (let ()
							 (define-struct name_ (field_ ...) (make-inspector))
							 (values proc-name ...)))
						   'stepper-define-struct-hint
						   stx))))])
                 (let ([defn
                         (quasisyntax/loc stx
                           (begin
                             #,(stepper-syntax-property #`(define-syntaxes (name_) compile-info)
                                                        'stepper-skip-completely
                                                        #t)
                             #,defn0))])
                   (check-definitions-new 'define-struct
                                          stx 
                                          (cons #'name_ to-define-names)
                                          defn
                                          (and setters? bind-names)))))))]
	[(_ name_ something . rest)
	 (teach-syntax-error
	  'define-struct
	  stx
	  (syntax something)
	  "expected a sequence of field names after the structure type name in `define-struct', ~
         but found ~a"
	  (something-else (syntax something)))]
	[(_ name_)
	 (teach-syntax-error
	  'define-struct
	  stx
	  (syntax something)
	  "expected a sequence of field names after the structure type name in `define-struct', ~
         but nothing's there")]
	[(_)
	 (teach-syntax-error
	  'define-struct
	  stx
	  #f
	  "expected a structure type name after `define-struct', but nothing's there")]
	[_else (bad-use-error 'define-struct stx)]))

    (define (beginner-define-struct/proc stx)
      (do-define-struct stx #t #f #t))

    (define (intermediate-define-struct/proc stx)
      (do-define-struct stx #f #f #t))

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; application (beginner and intermediate)
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;; For beginner:

    ;; #%app should never happen in beginner. Primitive operations and
    ;; defined functions turn into syntax that handle application
    ;; forms.  The only vaguely legitimate application would involve a
    ;; poorly implemented teachpack that exports functions instead of
    ;; primitive operators. Also, #%app is unavoidable in the REPL.

    ;; An #%app might happen "temporarily" if it appears at the top
    ;; level before the corresponding function definition. To provide
    ;; a good error message, we need to wait, and that's what
    ;; beginner-app-delay does.

    ;; For intermediate:

    ;; This application form disallows rator expressions that aren't
    ;; top-level identifiers or of the form `(check-not-undefined ...)'.

    ;; The latter is probably surprising. It turns out that every use of
    ;; a `local'-bound identifier gets converted to an undefined check,
    ;; and the call to `check-not-undefined' can't be forged by the
    ;; programmer. So the pattern-match effectively recognizes uses of
    ;; `local'-bound identifiers, which are legal as rator
    ;; expressions. (`let' and `letrec' get converted to `local'.)

    (define-values (beginner-app/proc intermediate-app/proc)
      (let ([mk-app
	     (lambda (lex-ok?)
	       (lambda (stx)
		 (syntax-case stx ()
		   [(_ rator rand ...)
		    (let* ([fun (syntax rator)]
			   [undef-check? (syntax-case fun (check-not-undefined)
					   [(check-not-undefined id)
					    #t]
					   [_else #f])]
			   [binding (and (identifier? fun)
					 (identifier-binding fun))]
			   [lex? (eq? 'lexical binding)]
			   [bad-app (lambda (what)
				      (teach-syntax-error
				       '|function call|
					 stx
					 fun
					 "expected a ~a after an open parenthesis, but found ~a"
					 (if lex-ok?
					     "name"
					     "defined name or a primitive operation name")
					 what))])
		      (unless (and (identifier? fun) (or lex-ok? undef-check? (not lex?)))
			(bad-app (if lex?
				     "a function argument name"
				     (something-else fun))))
		      ;; The following check disallows calling thunks.
		      ;; It's disabled because we need to allow calls to
		      ;; primitive thunks.
		      '(when (null? (syntax->list (syntax (rand ...))))
			 (teach-syntax-error
			  '|function call|
			    stx
			    #f
			    "expected an argument after the function name for a function call, ~
                             but nothing's there"))
		      (cond
		       [(and (not lex-ok?) (binding-in-this-module? binding))
			;; An application of something defined as a constant
			(bad-app "something else")]
		       [(or lex-ok? (and binding (not (binding-in-this-module? binding))))
			(syntax/loc stx (#%app rator rand ...))]
		       [else
			;; We don't know what rator is, yet, and it might be local:
			(quasisyntax/loc 
			 stx 
			 (#%app values #,(quasisyntax/loc
					  stx
					  (beginner-app-continue rator rand ...))))]))]
		   [(_)
		    (teach-syntax-error
		     '|function call|
		       stx
		       #f
		       (format
			"expected a ~a after an open parenthesis, but nothing's there"
			(if lex-ok?
			    "name"
			    "defined name or a primitive operation name")))]
		   [_else (bad-use-error '#%app stx)])))])
	(values (mk-app #f) (mk-app #t))))

    (define (beginner-app-continue/proc stx)
      (syntax-case stx ()
	[(_ rator rand ...)
	 (let* ([fun #'rator]
		[binding (identifier-binding fun)])
	   (if binding
	       ;; Now defined in the module:
	       (if (set!-transformer? (syntax-local-value fun (lambda () #f)))
		   ;; Something that takes care of itself:
		   (syntax/loc stx (rator rand ...))
		   ;; Something for which we probably need to report an error,
		   ;;  but let beginner-app take care of it:
		   (syntax/loc stx (beginner-app rator rand ...)))
	       ;; Something undefined; let beginner-top take care of it:
	       (syntax/loc stx (#%app rator rand ...))))]))

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; top-level variables (beginner)
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;; Report errors for undefined names (but only in modules)

    (define (beginner-top/proc stx)
      (syntax-case stx ()
        [(_ . id)
	 ;; If we're in a module, we'll need to check that the name
	 ;;  is bound....
	 (if (and (not (identifier-binding #'id))
		  (syntax-source-module #'id))
	     ;; ... but it might be defined later in the module, so
	     ;; delay the check.
             (stepper-ignore-checker 
              (syntax/loc stx (#%app values (beginner-top-continue id))))
	     (syntax/loc stx (#%top . id)))]))

    (define (beginner-top-continue/proc stx)
      (syntax-case stx ()
        [(_ id)
	 ;; If there's still no binding, it's an "unknown name" error.
	 (if (not (identifier-binding #'id))
	     (teach-syntax-error
	      'unknown
	      #'id
	      #f
	      "name is not defined, not a parameter, and not a primitive name")
	     ;; Don't use #%top here; id might have become bound to something
	     ;;  that isn't a value.
	     #'id)]))

    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; cond
    ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define (beginner-cond/proc stx)
      (ensure-expression
       stx
       (lambda ()
	 (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))
							  (module-identifier=? (syntax question) #'beginner-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 (beginner-else)
			  [(beginner-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 (stepper-syntax-property (syntax #t) 'stepper-else #t)])
			       (syntax/loc clause (new-test answer))))]
			  [(question answer)
			   (with-syntax ([verified (stepper-ignore-checker (syntax (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))
					  (module-identifier=? (car parts) #'beginner-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 
{'fraction_non_alphanumeric': 0.14495682528017637, 'fraction_numerical': 0.0013001879619553697, 'mean_word_length': 1.9204672087168269, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 43, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 139, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6620889', 'n_tokens_mistral': 24101, 'n_tokens_neox': 20008, 'n_words': 6423}