Add disjoint syntax object type

* libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES):
  (DOT_X_FILES, DOT_DOC_FILES, noinst_HEADERS): Add syntax.c and
  syntax.h.
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/goops.c (class_syntax, scm_class_of, scm_goops_early_init):
* libguile/init.c (scm_init_guile):
* libguile/print.c (iprin1):
* libguile/tags.h (scm_tc7_syntax):
* module/oop/goops.scm (<syntax>):
* module/system/base/types.scm (%tc7-syntax, cell->object):
* module/system/vm/disassembler.scm (code-annotation): Wire up the new
  data type.
* libguile/syntax.c:
* libguile/syntax.h: New files.
* module/ice-9/boot-9.scm: Move new definitions to (system syntax
  internal).
* module/system/syntax.scm (print-syntax): New helper.
* module/system/vm/assembler.scm (statically-allocatable?)
  (intern-constant, link-data): Arrange to be able to write syntax
  objects into images.
* module/language/cps/types.scm (&syntax): New type.  Remove
  &hash-table; it was never detected, an internal binding, and we need
  the bit to avoid going into bignum territory.

module/ice-9/boot-9.scm

@@ -4087,10 +4087,15 @@ when none is available, reading FILE-NAME with READER."
     (module-export! to ids))
 
   (steal-bindings! the-root-module (resolve-module '(system syntax internal))
-                   '(syntax-local-binding
+                   '(syntax?
+                     syntax-local-binding
                      %syntax-module
                      syntax-locally-bound-identifiers
-                     syntax-session-id)))
+                     syntax-session-id
+                     make-syntax
+                     syntax-expression
+                     syntax-wrap
+                     syntax-module)))
 
 
 

module/language/cps/types.scm

@@ -84,6 +84,7 @@
   #:use-module (language cps intset)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-11)
+  #:use-module ((system syntax internal) #:select (syntax?))
   #:export (;; Specific types.
             &exact-integer
             &flonum
@@ -112,7 +113,7 @@
             &bytevector
             &bitvector
             &array
-            &hash-table
+            &syntax
 
             ;; Union types.
             &number &real
@@ -169,7 +170,7 @@
   &bytevector
   &bitvector
   &array
-  &hash-table
+  &syntax
 
   &f64
   &u64
@@ -348,6 +349,7 @@ minimum, and maximum."
    ((bytevector? val) (return &bytevector (bytevector-length val)))
    ((bitvector? val) (return &bitvector (bitvector-length val)))
    ((array? val) (return &array (array-rank val)))
+   ((syntax? val) (return &syntax 0))
    ((not (variable-bound? (make-variable val))) (return &unbound #f))
 
    (else (error "unhandled constant" val))))

module/oop/goops.scm

@@ -62,7 +62,7 @@
             <boolean> <char> <list> <pair> <null> <string> <symbol>
             <vector> <bytevector> <uvec> <foreign> <hashtable>
             <fluid> <dynamic-state> <frame> <vm> <vm-continuation>
-            <keyword> <atomic-box>
+            <keyword> <syntax> <atomic-box>
 
             ;; Numbers.
             <number> <complex> <real> <integer> <fraction>
@@ -1009,6 +1009,7 @@ slots as we go."
 (define-standard-class <integer> (<real>))
 (define-standard-class <fraction> (<real>))
 (define-standard-class <keyword> (<top>))
+(define-standard-class <syntax> (<top>))
 (define-standard-class <atomic-box> (<top>))
 (define-standard-class <unknown> (<top>))
 (define-standard-class <procedure> (<applicable>)

module/system/base/types.scm

@@ -23,6 +23,7 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-60)
+  #:use-module (system syntax internal)
   #:use-module (ice-9 match)
   #:use-module (ice-9 iconv)
   #:use-module (ice-9 format)
@@ -254,6 +255,7 @@ the matching bits, possibly with bitwise operations to extract it from BITS."
 (define %tc7-dynamic-state #x2d)
 (define %tc7-frame #x2f)
 (define %tc7-keyword #x35)
+(define %tc7-syntax #x3d)
 (define %tc7-program #x45)
 (define %tc7-vm-continuation #x47)
 (define %tc7-bytevector #x4d)
@@ -464,6 +466,10 @@ using BACKEND."
            (make-pointer address))
           (((_ & #x7f = %tc7-keyword) symbol)
            (symbol->keyword (cell->object symbol backend)))
+          (((_ & #x7f = %tc7-syntax) expression wrap module)
+           (make-syntax (cell->object expression backend)
+                        (cell->object wrap backend)
+                        (cell->object module backend)))
           (((_ & #x7f = %tc7-vm-continuation))
            (inferior-object 'vm-continuation address))
           (((_ & #x7f = %tc7-weak-set))

module/system/syntax.scm

@@ -20,7 +20,14 @@
 
 (define-module (system syntax)
   #:use-module (system syntax internal)
-  #:re-export (syntax-local-binding
+  #:re-export (syntax?
+               syntax-local-binding
                (%syntax-module . syntax-module)
                syntax-locally-bound-identifiers
                syntax-session-id))
+
+;; Used by syntax.c.
+(define (print-syntax obj port)
+  ;; FIXME: Use syntax->datum instad of syntax-expression, when
+  ;; syntax->datum can operate on new syntax objects.
+  (format port "#<syntax ~s>" (syntax-expression obj)))

module/system/vm/assembler.scm

@@ -47,6 +47,7 @@
   #:use-module (system vm dwarf)
   #:use-module (system vm elf)
   #:use-module (system vm linker)
+  #:use-module (system syntax internal)
   #:use-module (language bytecode)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
@@ -1017,7 +1018,8 @@ immediate, and @code{#f} otherwise."
   "Return @code{#t} if a non-immediate constant can be allocated
 statically, and @code{#f} if it would need some kind of runtime
 allocation."
-  (or (pair? x) (string? x) (stringbuf? x) (static-procedure? x) (array? x)))
+  (or (pair? x) (string? x) (stringbuf? x) (static-procedure? x)
+      (array? x) (syntax? x)))
 
 (define (intern-constant asm obj)
   "Add an object to the constant table, and return a label that can be
@@ -1045,6 +1047,10 @@ table, its existing label is used directly."
                 (append-reverse (field label (1+ i) (vector-ref obj i))
                                 inits))
             (reverse inits))))
+     ((syntax? obj)
+      (append (field label 1 (syntax-expression obj))
+              (field label 2 (syntax-wrap obj))
+              (field label 3 (syntax-module obj))))
      ((stringbuf? obj) '())
      ((static-procedure? obj)
       `((static-patch! ,label 1 ,(static-procedure-code obj))))
@@ -1181,6 +1187,7 @@ returned instead."
 ;(define-tc7-macro-assembler br-if-dynamic-state 45)
 ;(define-tc7-macro-assembler br-if-frame 47)
 (define-tc7-macro-assembler br-if-keyword #x35)
+;(define-tc7-macro-assembler br-if-syntax #x3d)
 ;(define-tc7-macro-assembler br-if-vm 55)
 ;(define-tc7-macro-assembler br-if-vm-cont 71)
 ;(define-tc7-macro-assembler br-if-rtl-program 69)
@@ -1391,6 +1398,7 @@ should be .data or .rodata), and return the resulting linker object.
   (define tc7-narrow-stringbuf tc7-stringbuf)
   (define tc7-wide-stringbuf (+ tc7-stringbuf stringbuf-wide-flag))
   (define tc7-ro-string (+ 21 #x200))
+  (define tc7-syntax #x3d)
   (define tc7-program 69)
   (define tc7-bytevector 77)
   (define tc7-bitvector 95)
@@ -1415,6 +1423,8 @@ should be .data or .rodata), and return the resulting linker object.
         (* 2 word-size))
        ((simple-vector? x)
         (* (1+ (vector-length x)) word-size))
+       ((syntax? x)
+        (* 4 word-size))
        ((simple-uniform-vector? x)
         (* 4 word-size))
        ((uniform-vector-backing-store? x)
@@ -1519,6 +1529,18 @@ should be .data or .rodata), and return the resulting linker object.
        ((keyword? obj)
         (write-placeholder asm buf pos))
 
+       ((syntax? obj)
+        (case word-size
+          ((4) (bytevector-u32-set! buf pos tc7-syntax endianness))
+          ((8) (bytevector-u64-set! buf pos tc7-syntax endianness))
+          (else (error "bad word size")))
+        (write-constant-reference buf (+ pos (* 1 word-size))
+                                  (syntax-expression obj))
+        (write-constant-reference buf (+ pos (* 2 word-size))
+                                  (syntax-wrap obj))
+        (write-constant-reference buf (+ pos (* 3 word-size))
+                                  (syntax-module obj)))
+
        ((number? obj)
         (write-placeholder asm buf pos))
 

module/system/vm/disassembler.scm

@@ -210,6 +210,7 @@ address of that offset."
                         ((13) "vector?")
                         ((15) "string?")
                         ((53) "keyword?")
+                        ((#x3d) "syntax?")
                         ((77) "bytevector?")
                         ((95) "bitvector?")
                         (else (number->string tc7)))))