mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

psyntax: Cleanups; ensure order of top-level expansion

Browse source 
* module/ice-9/psyntax.scm (build-lexical-reference): No "type"
parameter.  Adapt callers.
(valid-bound-ids?, distinct-bound-ids?, bound-id-member?): Use match.
(expand-sequence, expand-top-sequence): Use match.  For
expand-top-sequence, ensure that both phases of expansion are run in
order; was the case before, but by accident.  Don't accumulate results
in reverse.
(parse-when-list): Use match.
This commit is contained in:
Andy Wingo 2024-11-18 11:15:15 +01:00
parent 12afcc74fb
commit b4aebbd7a5
1 changed files with 71 additions and 64 deletions
Download patch file Download diff file Expand all files Collapse all files

135
module/ice-9/psyntax.scm
View file

@ -214,7 +214,7 @@
(define (build-conditional sourcev test-exp then-exp else-exp) (define (build-conditional sourcev test-exp then-exp else-exp)
(make-conditional sourcev test-exp then-exp else-exp)) (make-conditional sourcev test-exp then-exp else-exp))
(define (build-lexical-reference type sourcev name var) (define (build-lexical-reference sourcev name var)
(make-lexical-ref sourcev name var)) (make-lexical-ref sourcev name var))
(define (build-lexical-assignment sourcev name var exp) (define (build-lexical-assignment sourcev name var exp)
@ -306,7 +306,7 @@
(make-letrec (make-letrec
src #f src #f
(list f-name) (list f) (list (maybe-name-value f-name proc)) (list f-name) (list f) (list (maybe-name-value f-name proc))
(build-call src (build-lexical-reference 'fun src f-name f) (build-call src (build-lexical-reference src f-name f)
(map maybe-name-value ids val-exps))))))))) (map maybe-name-value ids val-exps)))))))))
(define (build-letrec src in-order? ids vars val-exps body-exp) (define (build-letrec src in-order? ids vars val-exps body-exp)
@ -897,9 +897,10 @@
(define (valid-bound-ids? ids) (define (valid-bound-ids? ids)
(and (let all-ids? ((ids ids)) (and (let all-ids? ((ids ids))
(or (null? ids) (match ids
(and (id? (car ids)) (() #t)
(all-ids? (cdr ids))))) ((id . ids)
(and (id? id) (all-ids? ids)))))
(distinct-bound-ids? ids))) (distinct-bound-ids? ids)))
;; distinct-bound-ids? expects a list of ids and returns #t if there are ;; distinct-bound-ids? expects a list of ids and returns #t if there are
@ -910,14 +911,18 @@
(define (distinct-bound-ids? ids) (define (distinct-bound-ids? ids)
(let distinct? ((ids ids)) (let distinct? ((ids ids))
(or (null? ids) (match ids
(and (not (bound-id-member? (car ids) (cdr ids))) (() #t)
(distinct? (cdr ids)))))) ((id . ids)
(and (not (bound-id-member? id ids))
(distinct? ids))))))
(define (bound-id-member? x list) (define (bound-id-member? x ids)
(and (not (null? list)) (match ids
(or (bound-id=? x (car list)) (() #f)
(bound-id-member? x (cdr list))))) ((id . ids)
(or (bound-id=? x id)
(bound-id-member? x ids)))))
;; wrapping expressions and identifiers ;; wrapping expressions and identifiers
@ -944,11 +949,12 @@
(define (expand-sequence body r w s mod) (define (expand-sequence body r w s mod)
(build-sequence s (build-sequence s
(let dobody ((body body) (r r) (w w) (mod mod)) (let lp ((body body))
(if (null? body) (match body
'() (() '())
(let ((first (expand (car body) r w mod))) ((head . tail)
(cons first (dobody (cdr body) r w mod))))))) (let ((expr (expand head r w mod)))
(cons expr (lp tail))))))))
;; At top-level, we allow mixed definitions and expressions. Like ;; At top-level, we allow mixed definitions and expressions. Like
;; expand-body we expand in two passes. ;; expand-body we expand in two passes.
@ -991,10 +997,11 @@
;; to appending a uniquifying integer. ;; to appending a uniquifying integer.
(define (ribcage-has-var? var) (define (ribcage-has-var? var)
(let lp ((labels (ribcage-labels ribcage))) (let lp ((labels (ribcage-labels ribcage)))
(and (pair? labels) (match labels
(let ((wrapped (cdar labels))) (() #f)
(or (eq? (syntax-expression wrapped) var) (((_ . wrapped) . labels)
(lp (cdr labels))))))) (or (eq? (syntax-expression wrapped) var)
(lp labels))))))
(let lp ((unique var) (n 1)) (let lp ((unique var) (n 1))
(if (ribcage-has-var? unique) (if (ribcage-has-var? unique)
(let ((tail (string->symbol (number->string n)))) (let ((tail (string->symbol (number->string n))))
@ -1012,21 +1019,22 @@
(hash (syntax->datum orig-form) most-positive-fixnum) (hash (syntax->datum orig-form) most-positive-fixnum)
16))))) 16)))))
(define (parse body r w s m esew mod) (define (parse body r w s m esew mod)
(let lp ((body body) (exps '())) (let lp ((body body))
(if (null? body) (match body
exps (() '())
(lp (cdr body) ((head . tail)
(append (parse1 (car body) r w s m esew mod) (let ((thunks (parse1 head r w s m esew mod)))
exps))))) (append thunks (lp tail)))))))
(define (parse1 x r w s m esew mod) (define (parse1 x r w s m esew mod)
(define (current-module-for-expansion mod) (define (current-module-for-expansion mod)
(case (car mod) (match mod
;; If the module was just put in place for hygiene, in a (('hygiene . _)
;; top-level `begin' always recapture the current ;; If the module was just put in place for hygiene, in a
;; module. If a user wants to override, then we need to ;; top-level `begin' always recapture the current
;; use @@ or similar. ;; module. If a user wants to override, then we need to
((hygiene) (cons 'hygiene (module-name (current-module)))) ;; use @@ or similar.
(else mod))) (cons 'hygiene (module-name (current-module))))
(_ mod)))
(call-with-values (call-with-values
(lambda () (lambda ()
(let ((mod (current-module-for-expansion mod))) (let ((mod (current-module-for-expansion mod)))
@ -1049,10 +1057,10 @@
(lambda (type* value* mod*) (lambda (type* value* mod*)
;; If the identifier to be bound is currently bound to a ;; If the identifier to be bound is currently bound to a
;; macro, then immediately discard that binding. ;; macro, then immediately discard that binding.
(if (eq? type* 'macro) (when (eq? type* 'macro)
(top-level-eval (build-global-definition (top-level-eval (build-global-definition
s mod var (build-void s)) s mod var (build-void s))
mod)) mod))
(lambda () (lambda ()
(build-global-definition s mod var (expand e r w mod))))))))) (build-global-definition s mod var (expand e r w mod)))))))))
((define-syntax-form define-syntax-parameter-form) ((define-syntax-form define-syntax-parameter-form)
@ -1079,10 +1087,10 @@
(top-level-eval e mod) (top-level-eval e mod)
(list (lambda () e)))) (list (lambda () e))))
(else (else
(if (memq 'eval esew) (when (memq 'eval esew)
(top-level-eval (top-level-eval
(expand-install-global mod var type (expand e r w mod)) (expand-install-global mod var type (expand e r w mod))
mod)) mod))
'())))) '()))))
((begin-form) ((begin-form)
(syntax-case e () (syntax-case e ()
@ -1105,10 +1113,10 @@
(recurse (if (memq 'expand when-list) 'c&e 'e) (recurse (if (memq 'expand when-list) 'c&e 'e)
'(eval)) '(eval))
(begin (begin
(if (memq 'expand when-list) (when (memq 'expand when-list)
(top-level-eval (top-level-eval
(expand-top-sequence body r w s 'e '(eval) mod) (expand-top-sequence body r w s 'e '(eval) mod)
mod)) mod))
'()))) '())))
((memq 'load when-list) ((memq 'load when-list)
(if (or (memq 'compile when-list) (if (or (memq 'compile when-list)
@ -1135,11 +1143,12 @@
(lambda () x)) (lambda () x))
(lambda () (lambda ()
(expand-expr type value form e r w s mod))))))))) (expand-expr type value form e r w s mod)))))))))
(let ((exps (map (lambda (x) (x)) (match (let lp ((thunks (parse body r w s m esew mod)))
(reverse (parse body r w s m esew mod))))) (match thunks
(if (null? exps) (() '())
(build-void s) ((thunk . thunks) (cons (thunk) (lp thunks)))))
(build-sequence s exps))))) (() (build-void s))
(exps (build-sequence s exps)))))
(define (expand-install-global mod name type e) (define (expand-install-global mod name type e)
(build-global-definition (build-global-definition
@ -1159,12 +1168,12 @@
(define (parse-when-list e when-list) (define (parse-when-list e when-list)
(let ((result (strip when-list))) (let ((result (strip when-list)))
(let lp ((l result)) (let lp ((l result))
(if (null? l) (match l
result (() result)
(if (memq (car l) '(compile load eval expand)) ((x . l)
(lp (cdr l)) (match x
(syntax-violation 'eval-when "invalid situation" e ((or 'compile 'load 'eval 'expand) (lp l))
(car l))))))) (_ (syntax-violation 'eval-when "invalid situation" e x))))))))
;; syntax-type returns seven values: type, value, form, e, w, s, and ;; syntax-type returns seven values: type, value, form, e, w, s, and
;; mod. The first two are described in the table below. ;; mod. The first two are described in the table below.
@ -1306,7 +1315,7 @@
(define (expand-expr type value form e r w s mod) (define (expand-expr type value form e r w s mod)
(case type (case type
((lexical) ((lexical)
(build-lexical-reference 'value s e value)) (build-lexical-reference s e value))
((core core-form) ((core core-form)
;; apply transformer ;; apply transformer
(value e r w s mod)) (value e r w s mod))
@ -1317,7 +1326,7 @@
((lexical-call) ((lexical-call)
(expand-call (expand-call
(let ((id (car e))) (let ((id (car e)))
(build-lexical-reference 'fun (source-annotation id) (build-lexical-reference (source-annotation id)
(if (syntax? id) (if (syntax? id)
(syntax->datum id) (syntax->datum id)
id) id)
@ -2119,7 +2128,7 @@
(define (regen x) (define (regen x)
(case (car x) (case (car x)
((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x))) ((ref) (build-lexical-reference no-source (cadr x) (cadr x)))
((primitive) (build-primref no-source (cadr x))) ((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x))) ((quote) (build-data no-source (cadr x)))
((lambda) ((lambda)
@ -2539,8 +2548,7 @@
;; fat finger binding and references to temp variable y ;; fat finger binding and references to temp variable y
(build-call no-source (build-call no-source
(build-simple-lambda no-source (list 'tmp) #f (list y) '() (build-simple-lambda no-source (list 'tmp) #f (list y) '()
(let ((y (build-lexical-reference 'value no-source (let ((y (build-lexical-reference no-source 'tmp y)))
'tmp y)))
(build-conditional no-source (build-conditional no-source
(syntax-case fender () (syntax-case fender ()
(#t y) (#t y)
@ -2601,8 +2609,7 @@
;; fat finger binding and references to temp variable x ;; fat finger binding and references to temp variable x
(build-call s (build-call s
(build-simple-lambda no-source (list 'tmp) #f (list x) '() (build-simple-lambda no-source (list 'tmp) #f (list x) '()
(gen-syntax-case (build-lexical-reference 'value no-source (gen-syntax-case (build-lexical-reference no-source 'tmp x)
'tmp x)
#'(key ...) #'(m ...) #'(key ...) #'(m ...)
r r
mod)) mod))