summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorMikael Djurfeldt <mikael@djurfeldt.com>2024-12-06 10:26:29 +0100
committerMikael Djurfeldt <mikael@djurfeldt.com>2024-12-06 10:26:29 +0100
commit47807c9b118c190fbb6487b2b028170861d7cf5b (patch)
tree4c9a9f3aa167f94c48d9a363c083baa273417d8b /module
parent76afb429ee7a8a4c9eddb20bf29a2246192f8a28 (diff)
downloadguile-47807c9b118c190fbb6487b2b028170861d7cf5b.tar.gz
Temporarily revert commit 7379049d3 (to make Guile bootstrap)
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/psyntax-pp.scm196
-rw-r--r--module/ice-9/psyntax.scm38
2 files changed, 79 insertions, 155 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index ab5590f0e..d5b428d8c 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -46,63 +46,6 @@
(lambda-src (lambda (x) (struct-ref x 0)))
(lambda-meta (lambda (x) (struct-ref x 1)))
(lambda-body (lambda (x) (struct-ref x 2)))
- (resolve-module*
- (lambda (mod)
- (let* ((v mod)
- (fk (lambda ()
- (let ((fk (lambda ()
- (let ((fk (lambda ()
- (let ((fk (lambda () (error "value failed to match" v))))
- (if (pair? v)
- (let ((vx (car v)) (vy (cdr v)))
- (let ((tk (lambda ()
- (let ((mod vy))
- (resolve-module mod #:ensure #f)))))
- (if (eq? vx 'private)
- (tk)
- (let ((tk (lambda () (tk))))
- (if (eq? vx 'hygiene) (tk) (fk))))))
- (fk))))))
- (if (pair? v)
- (let ((vx (car v)) (vy (cdr v)))
- (if (eq? vx 'public)
- (let* ((mod vy)
- (v (resolve-module mod #:ensure #f))
- (fk (lambda ()
- (let* ((fk (lambda ()
- (error "value failed to match" v)))
- (mod v))
- (module-public-interface mod)))))
- (if (eq? v #f) #f (fk)))
- (fk)))
- (fk))))))
- (if (pair? v)
- (let ((vx (car v)) (vy (cdr v)))
- (if (eq? vx 'primitive) (if (null? vy) #f (fk)) (fk)))
- (fk))))))
- (if (eq? v #f) (current-module) (fk)))))
- (resolve-variable
- (lambda (mod var)
- (let* ((v (resolve-module* mod))
- (fk (lambda ()
- (let* ((fk (lambda () (error "value failed to match" v))) (mod v))
- (module-variable mod var)))))
- (if (eq? v #f)
- (let* ((v (current-module))
- (fk (lambda () (let ((fk (lambda () (error "value failed to match" v)))) #f))))
- (if (eq? v #f)
- (let* ((v mod) (fk (lambda () (error "value failed to match" v))))
- (if (pair? v)
- (let ((vx (car v)) (vy (cdr v)))
- (if (eq? vx 'hygiene)
- (if (pair? vy)
- (let ((vx (car vy)) (vy (cdr vy)))
- (if (eq? vx 'guile) (if (null? vy) (module-variable #f var) (fk)) (fk)))
- (fk))
- (fk)))
- (fk)))
- (fk)))
- (fk)))))
(top-level-eval (lambda (x mod) (primitive-eval x)))
(local-eval (lambda (x mod) (primitive-eval x)))
(global-extend
@@ -628,7 +571,8 @@
(lambda (var mod)
(if (and (not mod) (current-module))
(warn "module system is booted, we should have a module" var))
- (let ((v (resolve-variable mod var)))
+ (let ((v (and (not (equal? mod '(primitive)))
+ (module-variable (if mod (resolve-module (cdr mod)) (current-module)) var))))
(if (and v (variable-bound? v) (macro? (variable-ref v)))
(let* ((m (variable-ref v)) (type (macro-type m)) (trans (macro-binding m)))
(if (eq? type 'syntax-parameter)
@@ -671,7 +615,9 @@
(mj (and (syntax? j) (syntax-module j)))
(ni (id-var-name i empty-wrap mi))
(nj (id-var-name j empty-wrap mj)))
- (letrec* ((id-module-binding (lambda (id mod) (resolve-variable mod (id-sym-name id)))))
+ (letrec* ((id-module-binding
+ (lambda (id mod)
+ (module-variable (if mod (resolve-module (cdr mod)) (current-module)) (id-sym-name id)))))
(cond
((syntax? ni) (free-id=? ni j))
((syntax? nj) (free-id=? i nj))
@@ -1195,11 +1141,11 @@
(source-wrap e w (wrap-subst w) mod)
x))
(else (decorate-source x))))))
- (let* ((t-680b775fb37a463-cc0 transformer-environment)
- (t-680b775fb37a463-cc1 (lambda (k) (k e r w s rib mod))))
+ (let* ((t-680b775fb37a463-c45 transformer-environment)
+ (t-680b775fb37a463-c46 (lambda (k) (k e r w s rib mod))))
(with-fluid*
- t-680b775fb37a463-cc0
- t-680b775fb37a463-cc1
+ t-680b775fb37a463-c45
+ t-680b775fb37a463-c46
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
(expand-body
(lambda (body outer-form r w mod)
@@ -1730,11 +1676,11 @@
s
mod
get-formals
- (map (lambda (tmp-680b775fb37a463-f49
- tmp-680b775fb37a463-f48
- tmp-680b775fb37a463-f47)
- (cons tmp-680b775fb37a463-f47
- (cons tmp-680b775fb37a463-f48 tmp-680b775fb37a463-f49)))
+ (map (lambda (tmp-680b775fb37a463-ece
+ tmp-680b775fb37a463-ecd
+ tmp-680b775fb37a463-ecc)
+ (cons tmp-680b775fb37a463-ecc
+ (cons tmp-680b775fb37a463-ecd tmp-680b775fb37a463-ece)))
e2*
e1*
args*)))
@@ -2007,11 +1953,8 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-11ae
- tmp-680b775fb37a463-11ad
- tmp-680b775fb37a463-11ac)
- (cons tmp-680b775fb37a463-11ac
- (cons tmp-680b775fb37a463-11ad tmp-680b775fb37a463-11ae)))
+ (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2
e1
args)))
@@ -2021,11 +1964,9 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum docstring)))
- (map (lambda (tmp-680b775fb37a463-11c4
- tmp-680b775fb37a463-11c3
- tmp-680b775fb37a463-11c2)
- (cons tmp-680b775fb37a463-11c2
- (cons tmp-680b775fb37a463-11c3 tmp-680b775fb37a463-11c4)))
+ (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (cons tmp-680b775fb37a463
+ (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2
e1
args)))
@@ -2043,11 +1984,8 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-11e4
- tmp-680b775fb37a463-11e3
- tmp-680b775fb37a463-11e2)
- (cons tmp-680b775fb37a463-11e2
- (cons tmp-680b775fb37a463-11e3 tmp-680b775fb37a463-11e4)))
+ (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2
e1
args)))
@@ -2057,11 +1995,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum docstring)))
- (map (lambda (tmp-680b775fb37a463-11fa
- tmp-680b775fb37a463-11f9
- tmp-680b775fb37a463-11f8)
- (cons tmp-680b775fb37a463-11f8
- (cons tmp-680b775fb37a463-11f9 tmp-680b775fb37a463-11fa)))
+ (map (lambda (tmp-680b775fb37a463-117f
+ tmp-680b775fb37a463-117e
+ tmp-680b775fb37a463-117d)
+ (cons tmp-680b775fb37a463-117d
+ (cons tmp-680b775fb37a463-117e tmp-680b775fb37a463-117f)))
e2
e1
args)))
@@ -2884,9 +2822,9 @@
#f
k
'()
- (map (lambda (tmp-680b775fb37a463-14d8 tmp-680b775fb37a463-14d7 tmp-680b775fb37a463-14d6)
- (list (cons tmp-680b775fb37a463-14d6 tmp-680b775fb37a463-14d7)
- tmp-680b775fb37a463-14d8))
+ (map (lambda (tmp-680b775fb37a463-145d tmp-680b775fb37a463-145c tmp-680b775fb37a463-145b)
+ (list (cons tmp-680b775fb37a463-145b tmp-680b775fb37a463-145c)
+ tmp-680b775fb37a463-145d))
template
pattern
keyword)))
@@ -2901,11 +2839,8 @@
#f
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-14f1
- tmp-680b775fb37a463-14f0
- tmp-680b775fb37a463-14ef)
- (list (cons tmp-680b775fb37a463-14ef tmp-680b775fb37a463-14f0)
- tmp-680b775fb37a463-14f1))
+ (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2))
template
pattern
keyword)))
@@ -2917,9 +2852,11 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-150a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
- tmp-680b775fb37a463-150a))
+ (map (lambda (tmp-680b775fb37a463-148f
+ tmp-680b775fb37a463-148e
+ tmp-680b775fb37a463-148d)
+ (list (cons tmp-680b775fb37a463-148d tmp-680b775fb37a463-148e)
+ tmp-680b775fb37a463-148f))
template
pattern
keyword)))
@@ -2935,11 +2872,11 @@
dots
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-2
- tmp-680b775fb37a463-1
- tmp-680b775fb37a463)
- (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
- tmp-680b775fb37a463-2))
+ (map (lambda (tmp-680b775fb37a463-14ae
+ tmp-680b775fb37a463-14ad
+ tmp-680b775fb37a463-14ac)
+ (list (cons tmp-680b775fb37a463-14ac tmp-680b775fb37a463-14ad)
+ tmp-680b775fb37a463-14ae))
template
pattern
keyword)))
@@ -3067,9 +3004,9 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda (tmp-680b775fb37a463-15d6)
+ (map (lambda (tmp-680b775fb37a463-155b)
(list "value"
- tmp-680b775fb37a463-15d6))
+ tmp-680b775fb37a463-155b))
p)
(quasi q lev))
(quasicons
@@ -3095,9 +3032,9 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda (tmp-680b775fb37a463-15db)
+ (map (lambda (tmp-680b775fb37a463)
(list "value"
- tmp-680b775fb37a463-15db))
+ tmp-680b775fb37a463))
p)
(quasi q lev))
(quasicons
@@ -3133,8 +3070,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda (tmp-680b775fb37a463-15f1)
- (list "value" tmp-680b775fb37a463-15f1))
+ (map (lambda (tmp-680b775fb37a463)
+ (list "value" tmp-680b775fb37a463))
p)
(vquasi q lev))
(quasicons
@@ -3154,8 +3091,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda (tmp-680b775fb37a463-15f6)
- (list "value" tmp-680b775fb37a463-15f6))
+ (map (lambda (tmp-680b775fb37a463-157b)
+ (list "value" tmp-680b775fb37a463-157b))
p)
(vquasi q lev))
(quasicons
@@ -3237,8 +3174,8 @@
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463-163f)
- (cons "vector" t-680b775fb37a463-163f))
+ (apply (lambda (t-680b775fb37a463-15c4)
+ (cons "vector" t-680b775fb37a463-15c4))
tmp)
(syntax-violation
#f
@@ -3248,8 +3185,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda (tmp-680b775fb37a463-164b)
- (list "quote" tmp-680b775fb37a463-164b))
+ (k (map (lambda (tmp-680b775fb37a463-15d0)
+ (list "quote" tmp-680b775fb37a463-15d0))
y)))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@@ -3260,8 +3197,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp))
(let ((tmp x))
- (let ((t-680b775fb37a463-165a tmp))
- (list "list->vector" t-680b775fb37a463-165a)))))))))))))))))
+ (let ((t-680b775fb37a463-15df tmp))
+ (list "list->vector" t-680b775fb37a463-15df)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@@ -3273,9 +3210,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463)
+ (apply (lambda (t-680b775fb37a463-15ee)
(cons (make-syntax 'list '((top)) '(hygiene guile))
- t-680b775fb37a463))
+ t-680b775fb37a463-15ee))
tmp)
(syntax-violation
#f
@@ -3291,14 +3228,13 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp
- (apply (lambda (t-680b775fb37a463-167d
- t-680b775fb37a463-167c)
+ (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463)
(list (make-syntax
'cons
'((top))
'(hygiene guile))
- t-680b775fb37a463-167d
- t-680b775fb37a463-167c))
+ t-680b775fb37a463-1
+ t-680b775fb37a463))
tmp)
(syntax-violation
#f
@@ -3311,12 +3247,12 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463)
+ (apply (lambda (t-680b775fb37a463-160e)
(cons (make-syntax
'append
'((top))
'(hygiene guile))
- t-680b775fb37a463))
+ t-680b775fb37a463-160e))
tmp)
(syntax-violation
#f
@@ -3329,12 +3265,12 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463)
+ (apply (lambda (t-680b775fb37a463-161a)
(cons (make-syntax
'vector
'((top))
'(hygiene guile))
- t-680b775fb37a463))
+ t-680b775fb37a463-161a))
tmp)
(syntax-violation
#f
@@ -3345,12 +3281,12 @@
(if tmp-1
(apply (lambda (x)
(let ((tmp (emit x)))
- (let ((t-680b775fb37a463-16a1 tmp))
+ (let ((t-680b775fb37a463 tmp))
(list (make-syntax
'list->vector
'((top))
'(hygiene guile))
- t-680b775fb37a463-16a1))))
+ t-680b775fb37a463))))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 4a4d6a4c6..84fcd7262 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -178,29 +178,6 @@
(define-syntax-rule (match e cs ...) (simple-match e cs ...))
- (define (resolve-module* mod)
- (match mod
- (#f (current-module))
- (('primitive) #f)
- (('public . mod)
- ;; Defer possibly-failed binding of (@ (unknown-module) id) until
- ;; run-time.
- (match (resolve-module mod #:ensure #f)
- (#f #f)
- (mod (module-public-interface mod))))
- (((or 'private 'hygiene) . mod)
- (resolve-module mod #:ensure #f))))
-
- (define (resolve-variable mod var)
- (match (resolve-module* mod)
- (#f (match (current-module)
- (#f
- ;; Module system not yet booted.
- (match mod
- (('hygiene 'guile) (module-variable #f var))))
- (_ #f)))
- (mod (module-variable mod var))))
-
(define (top-level-eval x mod)
(primitive-eval x))
@@ -735,7 +712,11 @@
(define (resolve-global var mod)
(when (and (not mod) (current-module))
(warn "module system is booted, we should have a module" var))
- (let ((v (resolve-variable mod var)))
+ (let ((v (and (not (equal? mod '(primitive)))
+ (module-variable (if mod
+ (resolve-module (cdr mod))
+ (current-module))
+ var))))
;; The expander needs to know when a top-level definition from
;; outside the compilation unit is a macro.
;;
@@ -836,7 +817,14 @@
(ni (id-var-name i empty-wrap mi))
(nj (id-var-name j empty-wrap mj)))
(define (id-module-binding id mod)
- (resolve-variable mod (id-sym-name id)))
+ (module-variable
+ (if mod
+ ;; The normal case.
+ (resolve-module (cdr mod))
+ ;; Either modules have not been booted, or we have a
+ ;; raw symbol coming in, which is possible.
+ (current-module))
+ (id-sym-name id)))
(cond
((syntax? ni) (free-id=? ni j))
((syntax? nj) (free-id=? i nj))