* bug#74557: Patch to get main bootstrapping again
2024-11-27 13:07 bug#74557: Bootstrap no longer working Mikael Djurfeldt
@ 2024-11-30 17:50 ` Mikael Djurfeldt
0 siblings, 0 replies; 2+ messages in thread
From: Mikael Djurfeldt @ 2024-11-30 17:50 UTC (permalink / raw)
To: guile-devel, 74557; +Cc: Mikael Djurfeldt
[-- Attachment #1.1: Type: text/plain, Size: 365 bytes --]
Since commit 7379049d3, Guile is no longer bootstrapping. (Thanks to dsmith
and rlb in the chat.)
It turns out that the bad commit is solely 7379049d3 and the rest seem OK,
so I've prepared a patch to fix this. (I can commit it to main, but I
thought commit history will look nicer if Andy fixes this.)
BTW, is compile slower or faster now?
Best regards,
Mikael
[-- Attachment #1.2: Type: text/html, Size: 507 bytes --]
[-- Attachment #2: remove-7379049d3.patch --]
[-- Type: text/x-patch, Size: 31527 bytes --]
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))
^ permalink raw reply related [flat|nested] 2+ messages in thread