intdef-lambda.rkt

#lang racket/base

(require (for-syntax racket/base
                     racket/list
                     racket/match
                     syntax/kerncase)
         syntax/parse/define)

(define-syntax (argument stx) (raise-syntax-error #f "cannot be used as an expression" stx))

(define-syntax-parser intdef-lambda
  [(_ body ...+)
   (define ctx (list (gensym 'intdef)))
   (define intdef (syntax-local-make-definition-context))
   (define stops (cons #'argument (kernel-form-identifier-list)))

   (define-values [arg-ids expanded-bodies]
     (let loop ([bodies (attribute body)]
                [arg-ids '()]
                [expanded-bodies '()])
       (match bodies
         ['()
          (values arg-ids expanded-bodies)]
         [(cons body rest-bodies)
          (define expanded-body (local-expand body ctx stops intdef))
          (syntax-parse expanded-body
            #:literal-sets [kernel-literals]
            #:literals [argument]

            [(argument ~! x:id)
             (syntax-local-bind-syntaxes (list #'x) #f intdef)
             (loop rest-bodies (cons #'x arg-ids) expanded-bodies)]

            [(begin ~! body ...)
             (loop (append (attribute body) rest-bodies) arg-ids expanded-bodies)]

            [(define-values ~! [x:id ...] _:expr)
             (syntax-local-bind-syntaxes (attribute x) #f intdef)
             (loop rest-bodies arg-ids (cons expanded-body expanded-bodies))]

            [(define-syntaxes ~! [x:id ...] e:expr)
             (define expanded-e (local-transformer-expand #'e 'expression '() intdef))
             (syntax-local-bind-syntaxes (attribute x) expanded-e intdef)
             (define expanded-defn #`(define-syntaxes [x ...] #,expanded-e))
             (loop rest-bodies arg-ids (cons expanded-defn expanded-bodies))]

            [_
             (define expanded-expr #`(#%expression #,expanded-body))
             (loop rest-bodies arg-ids (cons expanded-expr expanded-bodies))])])))

   (quasisyntax/loc this-syntax
     (lambda #,(reverse arg-ids)
       #,@(reverse expanded-bodies)))])

;; ---------------------------------------------------------------------------------------------------

(define f
  (intdef-lambda
    (argument a)
    (argument b)
    (+ a b)))

(f 3 4)

(define g
  (intdef-lambda
    (argument a)
    (define b (* a 2))
    (argument c)
    (+ b c)))

(g 3 4)

(define h
  (intdef-lambda
    (argument a)
    (define-syntax m
      (begin
        (displayln "evaluating m")
        (syntax-rules () [(_) a])))
    (#%expression (m))))

(h 42)