+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
(let ()
(define-syntax define-structure
(lambda (x)
(define top-level-eval-hook
(lambda (x mod)
- (eval `(,noexpand ,x) (if mod (resolve-module mod)
- (interaction-environment)))))
+ (primitive-eval `(,noexpand ,x))))
(define local-eval-hook
(lambda (x mod)
- (eval `(,noexpand ,x) (if mod (resolve-module mod)
- (interaction-environment)))))
+ (primitive-eval `(,noexpand ,x))))
(define error-hook
(lambda (who why what)
((_) (gensym))))
(define put-global-definition-hook
- (lambda (symbol binding module)
- (let* ((module (if module
- (resolve-module module)
- (warn "wha" symbol (current-module))))
+ (lambda (symbol binding)
+ (let* ((module (current-module))
(v (or (module-variable module symbol)
- (let ((v (make-variable sc-macro)))
+ (let ((v (make-variable (gensym))))
(module-add! module symbol v)
v))))
- ;; Don't destroy Guile macros corresponding to primitive syntax
- ;; when syncase boots.
- (if (not (and (symbol-property symbol 'primitive-syntax)
- (eq? module the-syncase-module)))
- (variable-set! v sc-macro))
+ (if (not (variable-bound? v))
+ (variable-set! v (gensym)))
;; Properties are tied to variable objects
(set-object-property! v '*sc-expander* binding))))
+(define remove-global-definition-hook
+ (lambda (symbol)
+ (let* ((module (current-module))
+ (v (module-local-variable module symbol)))
+ (if v
+ (let ((p (assq '*sc-expander* (object-properties v))))
+ (set-object-properties! v (delq p (object-properties v))))))))
+
(define get-global-definition-hook
(lambda (symbol module)
(let* ((module (if module
- (resolve-module module)
- (warn "wha" symbol (current-module))))
+ (resolve-module (cdr module))
+ (let ((mod (current-module)))
+ (if mod (warn "wha" symbol))
+ mod)))
(v (module-variable module symbol)))
- (and v
- (or (object-property v '*sc-expander*)
- (and (variable-bound? v)
- (macro? (variable-ref v))
- (macro-transformer (variable-ref v)) ;non-primitive
- guile-macro))))))
+ (and v (object-property v '*sc-expander*)))))
+
)
(define-syntax build-global-reference
(syntax-rules ()
((_ source var mod)
- (build-annotated source
- (make-module-ref mod var #f)))))
+ (build-annotated
+ source
+ (if mod
+ (make-module-ref (cdr mod) var (car mod))
+ (make-module-ref mod var 'bare))))))
(define-syntax build-global-assignment
(syntax-rules ()
((_ source var exp mod)
(build-annotated source
- `(set! ,(make-module-ref mod var #f) ,exp)))))
+ `(set! ,(if mod
+ (make-module-ref (cdr mod) var (car mod))
+ (make-module-ref mod var 'bare))
+ ,exp)))))
(define-syntax build-global-definition
(syntax-rules ()
(define-syntax build-lambda
(syntax-rules ()
+ ((_ src vars docstring exp)
+ (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '())
+ ,exp)))
((_ src vars exp)
(build-annotated src `(lambda ,vars ,exp)))))
(define global-extend
(lambda (type sym val)
- (put-global-definition-hook sym (make-binding type val)
- (module-name (current-module)))))
+ (put-global-definition-hook sym (make-binding type val))))
;;; Conceptually, identifiers are always syntax objects. Internally,
mod))
((displaced-lexical)
(syntax-error (wrap value w mod) "identifier out of context"))
+ ((core macro module-ref)
+ (remove-global-definition-hook n)
+ (eval-if-c&e m
+ (build-global-definition s n (chi e r w mod) mod)
+ mod))
(else
- (if (eq? type 'external-macro)
- (eval-if-c&e m
- (build-global-definition s n (chi e r w mod) mod)
- mod)
- (syntax-error (wrap value w mod)
- "cannot define keyword at top level"))))))
+ (syntax-error (wrap value w mod)
+ "cannot define keyword at top level")))))
(else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
(define chi
;; apply transformer
(value e r w s mod))
((module-ref)
- (call-with-values (lambda () (value e r w s mod))
+ (call-with-values (lambda () (value e))
;; we could add a public? arg here
(lambda (id mod) (build-global-reference s id mod))))
((lexical-call)
(if rib
(cons rib (cons 'shift s))
(cons 'shift s)))
- (module-name (procedure-module p))))))) ;; hither the hygiene
+ (let ((pmod (procedure-module p)))
+ (if pmod
+ ;; hither the hygiene
+ (cons 'hygiene (module-name pmod))
+ ;; but it's possible for the proc to have
+ ;; no mod, if it was made before modules
+ ;; were booted
+ '(hygiene guile))))))))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector n)))
(do ((i 0 (fx+ i 1)))
(cdr body)))))))))))))))))
(define chi-lambda-clause
- (lambda (e c r w mod k)
+ (lambda (e docstring c r w mod k)
(syntax-case c ()
+ ((args doc e1 e2 ...)
+ (and (string? (syntax-object->datum (syntax doc))) (not docstring))
+ (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))
(((id ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(k new-vars
+ docstring
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
(if (null? ls1)
ls2
(f (cdr ls1) (cons (car ls1) ls2))))
+ docstring
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
(lambda (e r w s mod)
(syntax-case e ()
((_ . c)
- (chi-lambda-clause (source-wrap e w s mod) (syntax c) r w mod
- (lambda (vars body) (build-lambda s vars body)))))))
+ (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
+ (lambda (vars docstring body) (build-lambda s vars docstring body)))))))
(global-extend 'core 'let
(syntax-error (wrap (syntax id) w mod)
"identifier out of context"))
(else (syntax-error (source-wrap e w s mod)))))))
- ((_ (getter arg ...) val)
- (build-application s
- (chi (syntax (setter getter)) r w mod)
- (map (lambda (e) (chi e r w mod))
- (syntax (arg ... val)))))
+ ((_ (head tail ...) val)
+ (call-with-values
+ (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod))
+ (lambda (type value ee ww ss modmod)
+ (case type
+ ((module-ref)
+ (let ((val (chi (syntax val) r w mod)))
+ (call-with-values (lambda () (value (syntax (head tail ...))))
+ (lambda (id mod)
+ (build-global-assignment s id val mod)))))
+ (else
+ (build-application s
+ (chi (syntax (setter head)) r w mod)
+ (map (lambda (e) (chi e r w mod))
+ (syntax (tail ... val)))))))))
(_ (syntax-error (source-wrap e w s mod))))))
(global-extend 'module-ref '@
- (lambda (e r w s mod)
- (syntax-case e (%module-public-interface)
+ (lambda (e)
+ (syntax-case e ()
((_ (mod ...) id)
(and (andmap id? (syntax (mod ...))) (id? (syntax id)))
(values (syntax-object->datum (syntax id))
(syntax-object->datum
- (syntax (mod ... %module-public-interface))))))))
+ (syntax (public mod ...))))))))
(global-extend 'module-ref '@@
- (lambda (e r w s mod)
+ (lambda (e)
(syntax-case e ()
((_ (mod ...) id)
(and (andmap id? (syntax (mod ...))) (id? (syntax id)))
(values (syntax-object->datum (syntax id))
(syntax-object->datum
- (syntax (mod ...))))))))
+ (syntax (private mod ...))))))))
(global-extend 'begin 'begin '())
(if (and (pair? x) (equal? (car x) noexpand))
(cadr x)
(chi-top x null-env top-wrap m esew
- (module-name (current-module)))))))
+ (cons 'hygiene (module-name (current-module))))))))
(set! sc-expand3
(let ((m 'e) (esew '(eval)))
(if (or (null? rest) (null? (cdr rest)))
esew
(cadr rest))
- (module-name (current-module)))))))
+ (cons 'hygiene (module-name (current-module))))))))
(set! identifier?
(lambda (x)
HCoop / bpt / guile.git / blobdiff