From: Mikael Djurfeldt <mikael@djurfeldt.com>
To: guile-devel <guile-devel@gnu.org>, 74557@debbugs.gnu.org
Cc: Mikael Djurfeldt <mikael@djurfeldt.com>
Subject: Patch to get main bootstrapping again
Date: Sat, 30 Nov 2024 18:50:48 +0100 [thread overview]
Message-ID: <CAA2XvwK0RPy9EqimFRhzsuuyZ_g-UNHh+PwUTzjtdj0qi+SOyQ@mail.gmail.com> (raw)
[-- 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))
reply other threads:[~2024-11-30 17:50 UTC|newest]
Thread overview: [no followups] expand[flat|nested] mbox.gz Atom feed
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=CAA2XvwK0RPy9EqimFRhzsuuyZ_g-UNHh+PwUTzjtdj0qi+SOyQ@mail.gmail.com \
--to=mikael@djurfeldt.com \
--cc=74557@debbugs.gnu.org \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).