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

Add quote-syntax

Browse source 
* module/ice-9/psyntax.scm (quote-syntax): New core form.  Usually the
  expander will unwrap all syntax objects from the input term.  However
  sometimes you want to preserve a syntax object, as a datum.  That's
  when you want quote-syntax.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/local-eval.scm (identifier-syntax-from-box): Use
  quote-syntax instead of our datum->syntax trick, which relied on
  psyntax's special treatment of the top mark.
This commit is contained in:
Andy Wingo 2021-02-24 12:01:04 +01:00
parent a04a024f20
commit 1711608f15
3 changed files with 47 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

9
module/ice-9/local-eval.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*- ;;; -*- mode: scheme; coding: utf-8; -*-
;;; ;;;
;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc. ;;; Copyright (C) 2012, 2013, 2021 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software; you can redistribute it and/or ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -39,11 +39,6 @@
(syntax-module (lexenv-scope e)) (syntax-module (lexenv-scope e))
(+ (length (lexenv-boxes e)) (length (lexenv-patterns e)))))) (+ (length (lexenv-boxes e)) (length (lexenv-patterns e))))))
(define-syntax syntax-object-of
(lambda (form)
(syntax-case form ()
((_ x) #`(quote #,(datum->syntax #'x #'x))))))
(define-syntax-rule (make-box v) (define-syntax-rule (make-box v)
(case-lambda (case-lambda
(() v) (() v)
@ -55,7 +50,7 @@
(define-syntax-rule (identifier-syntax-from-box box) (define-syntax-rule (identifier-syntax-from-box box)
(make-transformer-from-box (make-transformer-from-box
(syntax-object-of box) (quote-syntax box)
(identifier-syntax (id (box)) (identifier-syntax (id (box))
((set! id x) (box x))))) ((set! id x) (box x)))))

70
module/ice-9/psyntax-pp.scm
View file

@ -991,11 +991,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x s)))))) (else (decorate-source x s))))))
(let* ((t-680b775fb37a463-d78 transformer-environment) (let* ((t-680b775fb37a463-d88 transformer-environment)
(t-680b775fb37a463-d79 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-d89 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-d78 t-680b775fb37a463-d88
t-680b775fb37a463-d79 t-680b775fb37a463-d89
(lambda () (lambda ()
(rebuild-macro-output (rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod)) (p (source-wrap e (anti-mark w) s mod))
@ -1562,11 +1562,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-fe9 (map (lambda (tmp-680b775fb37a463-ff9
tmp-680b775fb37a463-fe8 tmp-680b775fb37a463-ff8
tmp-680b775fb37a463-fe7) tmp-680b775fb37a463-ff7)
(cons tmp-680b775fb37a463-fe7 (cons tmp-680b775fb37a463-ff7
(cons tmp-680b775fb37a463-fe8 tmp-680b775fb37a463-fe9))) (cons tmp-680b775fb37a463-ff8 tmp-680b775fb37a463-ff9)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1661,6 +1661,14 @@
(if tmp (if tmp
(apply (lambda (e) (build-data s (strip e w))) tmp) (apply (lambda (e) (build-data s (strip e w))) tmp)
(syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
(global-extend
'core
'quote-syntax
(lambda (e r w s mod)
(let* ((tmp-1 (source-wrap e w s mod)) (tmp ($sc-dispatch tmp-1 '(_ any))))
(if tmp
(apply (lambda (e) (build-data s e)) tmp)
(let ((e tmp-1)) (syntax-violation 'quote "bad syntax" e))))))
(global-extend (global-extend
'core 'core
'syntax 'syntax
@ -2857,11 +2865,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-112f (map (lambda (tmp-680b775fb37a463-113f
tmp-680b775fb37a463-112e tmp-680b775fb37a463-113e
tmp-680b775fb37a463-112d) tmp-680b775fb37a463-113d)
(list (cons tmp-680b775fb37a463-112d tmp-680b775fb37a463-112e) (list (cons tmp-680b775fb37a463-113d tmp-680b775fb37a463-113e)
tmp-680b775fb37a463-112f)) tmp-680b775fb37a463-113f))
template template
pattern pattern
keyword))) keyword)))
@ -3068,8 +3076,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-121c) (map (lambda (tmp-680b775fb37a463-122c)
(list "value" tmp-680b775fb37a463-121c)) (list "value" tmp-680b775fb37a463-122c))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3223,8 +3231,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463-128c) (k (map (lambda (tmp-680b775fb37a463-129c)
(list "quote" tmp-680b775fb37a463-128c)) (list "quote" tmp-680b775fb37a463-129c))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@ -3235,8 +3243,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463-129b tmp)) (let ((t-680b775fb37a463-12ab tmp))
(list "list->vector" t-680b775fb37a463-129b))))))))))))))))) (list "list->vector" t-680b775fb37a463-12ab)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -3249,9 +3257,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12aa) (apply (lambda (t-680b775fb37a463-12ba)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12aa)) t-680b775fb37a463-12ba))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3267,10 +3275,10 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12be t-680b775fb37a463-12bd) (apply (lambda (t-680b775fb37a463-12ce t-680b775fb37a463-12cd)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-12be t-680b775fb37a463-12ce
t-680b775fb37a463-12bd)) t-680b775fb37a463-12cd))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3283,9 +3291,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12ca) (apply (lambda (t-680b775fb37a463-12da)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-12ca)) t-680b775fb37a463-12da))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3298,9 +3306,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12d6) (apply (lambda (t-680b775fb37a463-12e6)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463-12d6)) t-680b775fb37a463-12e6))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3311,9 +3319,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-12e2 tmp)) (let ((t-680b775fb37a463-12f2 tmp))
(list (make-syntax 'list->vector '((top)) '(hygiene guile)) (list (make-syntax 'list->vector '((top)) '(hygiene guile))
t-680b775fb37a463-12e2)))) t-680b775fb37a463-12f2))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1 (if tmp-1

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

@ -2106,6 +2106,12 @@
(_ (syntax-violation 'quote "bad syntax" (_ (syntax-violation 'quote "bad syntax"
(source-wrap e w s mod)))))) (source-wrap e w s mod))))))
(global-extend 'core 'quote-syntax
(lambda (e r w s mod)
(syntax-case (source-wrap e w s mod) ()
((_ e) (build-data s #'e))
(e (syntax-violation 'quote "bad syntax" #'e)))))
(global-extend (global-extend
'core 'syntax 'core 'syntax
(let () (let ()