mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
Temporarily revert commit 7379049d3 (to make Guile bootstrap)
This commit is contained in:
Mikael Djurfeldt
parent
76afb429ee
commit
47807c9b11
2 changed files with 79 additions and 155 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue