[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] branch main updated: Temporarily revert commit 7379049d3
From: |
Mikael Djurfeldt |
Subject: |
[Guile-commits] branch main updated: Temporarily revert commit 7379049d3 (to make Guile bootstrap) |
Date: |
Fri, 06 Dec 2024 04:27:50 -0500 |
This is an automated email from the git hooks/post-receive script.
mdj pushed a commit to branch main
in repository guile.
The following commit(s) were added to refs/heads/main by this push:
new 47807c9b1 Temporarily revert commit 7379049d3 (to make Guile bootstrap)
47807c9b1 is described below
commit 47807c9b118c190fbb6487b2b028170861d7cf5b
Author: Mikael Djurfeldt <mikael@djurfeldt.com>
AuthorDate: Fri Dec 6 10:26:29 2024 +0100
Temporarily revert commit 7379049d3 (to make Guile bootstrap)
---
module/ice-9/psyntax-pp.scm | 196 +++++++++++++++-----------------------------
module/ice-9/psyntax.scm | 38 +++------
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))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] branch main updated: Temporarily revert commit 7379049d3 (to make Guile bootstrap),
Mikael Djurfeldt <=