[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/13: Add quote-syntax
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/13: Add quote-syntax |
|
Date: |
Thu, 25 Feb 2021 15:39:06 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 1711608f150b5189fa85ab75e6314d70ed33a2b5
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Wed Feb 24 12:01:04 2021 +0100
Add quote-syntax
* 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.
---
module/ice-9/local-eval.scm | 9 ++----
module/ice-9/psyntax-pp.scm | 70 +++++++++++++++++++++++++--------------------
module/ice-9/psyntax.scm | 6 ++++
3 files changed, 47 insertions(+), 38 deletions(-)
diff --git a/module/ice-9/local-eval.scm b/module/ice-9/local-eval.scm
index b81daf3..ac8838f 100644
--- a/module/ice-9/local-eval.scm
+++ b/module/ice-9/local-eval.scm
@@ -1,6 +1,6 @@
;;; -*- 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
;;; modify it under the terms of the GNU Lesser General Public
@@ -39,11 +39,6 @@
(syntax-module (lexenv-scope 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)
(case-lambda
(() v)
@@ -55,7 +50,7 @@
(define-syntax-rule (identifier-syntax-from-box box)
(make-transformer-from-box
- (syntax-object-of box)
+ (quote-syntax box)
(identifier-syntax (id (box))
((set! id x) (box x)))))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index f0ee5eb..b23572a 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -991,11 +991,11 @@
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x s))))))
- (let* ((t-680b775fb37a463-d78 transformer-environment)
- (t-680b775fb37a463-d79 (lambda (k) (k e r w s rib mod))))
+ (let* ((t-680b775fb37a463-d88 transformer-environment)
+ (t-680b775fb37a463-d89 (lambda (k) (k e r w s rib mod))))
(with-fluid*
- t-680b775fb37a463-d78
- t-680b775fb37a463-d79
+ t-680b775fb37a463-d88
+ t-680b775fb37a463-d89
(lambda ()
(rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod))
@@ -1562,11 +1562,11 @@
s
mod
get-formals
- (map (lambda (tmp-680b775fb37a463-fe9
- tmp-680b775fb37a463-fe8
-
tmp-680b775fb37a463-fe7)
- (cons tmp-680b775fb37a463-fe7
- (cons
tmp-680b775fb37a463-fe8 tmp-680b775fb37a463-fe9)))
+ (map (lambda (tmp-680b775fb37a463-ff9
+ tmp-680b775fb37a463-ff8
+
tmp-680b775fb37a463-ff7)
+ (cons tmp-680b775fb37a463-ff7
+ (cons
tmp-680b775fb37a463-ff8 tmp-680b775fb37a463-ff9)))
e2*
e1*
args*)))
@@ -1663,6 +1663,14 @@
(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
+ 'core
'syntax
(letrec*
((gen-syntax
@@ -2857,11 +2865,11 @@
#f
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-112f
- tmp-680b775fb37a463-112e
- tmp-680b775fb37a463-112d)
- (list (cons tmp-680b775fb37a463-112d
tmp-680b775fb37a463-112e)
- tmp-680b775fb37a463-112f))
+ (map (lambda (tmp-680b775fb37a463-113f
+ tmp-680b775fb37a463-113e
+ tmp-680b775fb37a463-113d)
+ (list (cons tmp-680b775fb37a463-113d
tmp-680b775fb37a463-113e)
+ tmp-680b775fb37a463-113f))
template
pattern
keyword)))
@@ -3068,8 +3076,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-121c)
- (list
"value" tmp-680b775fb37a463-121c))
+ (map (lambda
(tmp-680b775fb37a463-122c)
+ (list
"value" tmp-680b775fb37a463-122c))
p)
(quasi q lev))
(quasicons
@@ -3223,8 +3231,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda (tmp-680b775fb37a463-128c)
- (list "quote"
tmp-680b775fb37a463-128c))
+ (k (map (lambda (tmp-680b775fb37a463-129c)
+ (list "quote"
tmp-680b775fb37a463-129c))
y)))
tmp-1)
(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)
(let ((else tmp))
(let ((tmp x))
- (let ((t-680b775fb37a463-129b tmp))
- (list "list->vector"
t-680b775fb37a463-129b)))))))))))))))))
+ (let ((t-680b775fb37a463-12ab tmp))
+ (list "list->vector"
t-680b775fb37a463-12ab)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@@ -3249,9 +3257,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12aa)
+ (apply (lambda
(t-680b775fb37a463-12ba)
(cons (make-syntax 'list
'((top)) '(hygiene guile))
-
t-680b775fb37a463-12aa))
+
t-680b775fb37a463-12ba))
tmp)
(syntax-violation
#f
@@ -3267,10 +3275,10 @@
(let ((tmp-1 (list (emit (car x*))
(f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1
'(any any))))
(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))
-
t-680b775fb37a463-12be
-
t-680b775fb37a463-12bd))
+
t-680b775fb37a463-12ce
+
t-680b775fb37a463-12cd))
tmp)
(syntax-violation
#f
@@ -3283,9 +3291,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12ca)
+ (apply (lambda
(t-680b775fb37a463-12da)
(cons (make-syntax
'append '((top)) '(hygiene guile))
-
t-680b775fb37a463-12ca))
+
t-680b775fb37a463-12da))
tmp)
(syntax-violation
#f
@@ -3298,9 +3306,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch
tmp-1 'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12d6)
+ (apply (lambda
(t-680b775fb37a463-12e6)
(cons
(make-syntax 'vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-12d6))
+
t-680b775fb37a463-12e6))
tmp)
(syntax-violation
#f
@@ -3311,9 +3319,9 @@
(if tmp-1
(apply (lambda (x)
(let ((tmp (emit x)))
- (let
((t-680b775fb37a463-12e2 tmp))
+ (let
((t-680b775fb37a463-12f2 tmp))
(list (make-syntax
'list->vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-12e2))))
+
t-680b775fb37a463-12f2))))
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 061beb9..430ba31 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2106,6 +2106,12 @@
(_ (syntax-violation 'quote "bad syntax"
(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
'core 'syntax
(let ()
- [Guile-commits] branch master updated (a04a024 -> 697f2b3), Andy Wingo, 2021/02/25
- [Guile-commits] 02/13: Remove top-marked? optimization from psyntax, Andy Wingo, 2021/02/25
- [Guile-commits] 09/13: Add syntax-sourcev, Andy Wingo, 2021/02/25
- [Guile-commits] 04/13: Ensure that (syntax ()) results in (), Andy Wingo, 2021/02/25
- [Guile-commits] 03/13: Fix module scoping for datum->syntax with no identifier, Andy Wingo, 2021/02/25
- [Guile-commits] 07/13: Commit updates from newest autoconf, Andy Wingo, 2021/02/25
- [Guile-commits] 11/13: Psyntax uses sourcev internally, Andy Wingo, 2021/02/25
- [Guile-commits] 06/13: Read Scheme via read-syntax, Andy Wingo, 2021/02/25
- [Guile-commits] 01/13: Add quote-syntax,
Andy Wingo <=
- [Guile-commits] 10/13: Assembler writes vector source properties, Andy Wingo, 2021/02/25
- [Guile-commits] 13/13: Shunt syntax-sourcev to (system syntax internal), Andy Wingo, 2021/02/25
- [Guile-commits] 12/13: read-syntax uses vector source representation, Andy Wingo, 2021/02/25
- [Guile-commits] 05/13: Fix read-syntax on vectors and arrays, Andy Wingo, 2021/02/25
- [Guile-commits] 08/13: Optimize run-time init and relocation procedure, Andy Wingo, 2021/02/25