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.

3 files changed, 47 insertions, 38 deletions

diff --git a/module/ice-9/local-eval.scm b/module/ice-9/local-eval.scm
index b81daf3e8..ac8838f1b 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 f0ee5eb40..b23572a67 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 061beb9cd..430ba3199 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 ()