Subject: Patch to get main bootstrapping again

From: Mikael Djurfeldt <[email-masked]>
Date: Sat, 30 Nov 2024 18:50:48 +0100

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
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))