(module require-transform '#%kernel (#%require "private/stxcase-scheme.ss" "private/qqstx.ss" "private/stx.ss" "private/define-struct.ss" "private/more-scheme.ss" "private/small-scheme.ss" "private/define.ss" (for-template (only '#%kernel quote)) (for-syntax '#%kernel "private/stxcase-scheme.ss")) (#%provide expand-import syntax-local-require-certifier make-require-transformer prop:require-transformer require-transformer? ;; the import struct type: import struct:import make-import import? import-local-id import-src-sym import-src-mod-path import-orig-stx import-mode import-req-mode import-orig-mode ;; the import-source struct type: import-source struct:import-source make-import-source import-source? import-source-mod-path-stx import-source-mode) (define-struct* import (local-id src-sym src-mod-path mode req-mode orig-mode orig-stx) #:guard (lambda (i s path mode req-mode orig-mode stx info) (unless (identifier? i) (raise-type-error 'make-import "identifier" i)) (unless (symbol? s) (raise-type-error 'make-import "symbol" s)) (unless (module-path? path) (raise-type-error 'make-import "module-path" path)) (unless (or (not mode) (exact-integer? mode)) (raise-type-error 'make-import "exact integer or #f" mode)) (unless (or (not req-mode) (exact-integer? req-mode)) (raise-type-error 'make-import "'exact integer or #f" req-mode)) (unless (or (not orig-mode) (exact-integer? orig-mode)) (raise-type-error 'make-import "'exact integer or #f" orig-mode)) (unless (equal? mode (and req-mode orig-mode (+ req-mode orig-mode))) (raise-mismatch-error 'make-import (format "orig mode: ~a and require mode: ~a not consistent with mode: " orig-mode req-mode) mode)) (unless (syntax? stx) (raise-type-error 'make-import "syntax" stx)) (values i s path mode req-mode orig-mode stx))) (define-struct* import-source (mod-path-stx mode) #:guard (lambda (path mode info) (unless (and (syntax? path) (module-path? (syntax->datum path))) (raise-type-error 'make-import-source "syntax module-path" path)) (unless (or (not mode) (exact-integer? mode)) (raise-type-error 'make-import-source "exact integer or #f" mode)) (values path mode))) (define-values (prop:require-transformer require-transformer? require-transformer-get-proc) (make-struct-type-property 'require-transformer)) (define-struct* rt (proc) #:property prop:require-transformer (lambda (t) (rt-proc t))) (define (make-require-transformer proc) (make-rt proc)) (define require-cert-key (gensym 'req)) (define (syntax-local-require-certifier) (let ([c (syntax-local-certifier)]) (case-lambda [(v) (c v require-cert-key)] [(v mark) (c v require-cert-key mark)]))) (define current-recertify (make-parameter (lambda (x) x))) ;; expand-import : stx bool -> (listof import) (define (expand-import stx) (syntax-case stx () [simple (or (identifier? #'simple) (string? (syntax-e #'simple)) (syntax-case stx (quote) [(quote s) #t] [_ #f])) (let ([mod-path (if (pair? (syntax-e #'simple)) `(quote . ,(cdr (syntax->datum #'simple))) (syntax->datum #'simple))]) (unless (module-path? mod-path) (raise-syntax-error #f "invalid module-path form" stx)) (let ([namess (syntax-local-module-exports stx)]) (values (apply append (map (lambda (names) (let ([mode (car names)]) (map (lambda (name) (make-import (datum->syntax stx name stx) name mod-path mode 0 mode stx)) (cdr names)))) namess)) (list (make-import-source #'simple 0)))))] [(id . rest) (identifier? #'id) (parameterize ([current-recertify (let ([prev (current-recertify)]) (lambda (sub) (syntax-recertify (prev sub) stx (current-code-inspector) require-cert-key)))]) (let ([t (syntax-local-value ((current-recertify) #'id) (lambda () #f))]) (if (require-transformer? t) (call-with-values (lambda () (((require-transformer-get-proc t) t) stx)) (case-lambda [(v mods) (unless (and (list? v) (andmap import? v)) (raise-syntax-error #f "first result from require transformer is not a list of imports" stx)) (unless (and (list? mods) (andmap import-source? mods)) (raise-syntax-error #f "second result from require transformer is not a list of import-sources" stx)) (values v mods)] [args (raise-syntax-error #f (format "require transformer produced ~a result~a instead of 2" (length args) (if (= 1 (length args)) "" "s")) stx)])) (raise-syntax-error #f "not a require sub-form" stx))))] [_ (raise-syntax-error #f "bad syntax for require sub-form" stx)])))