Merge branch 'main' into thesis

Author: michaelballantyne

info.rkt

@@ -11,4 +11,4 @@
 (define build-deps '("racket-doc" "scribble-lib" "drracket" "typed-racket-lib"))
 (define scribblings '(("scribblings/main.scrbl" (multi-page) (experimental) "syntax-spec-dev")))
 (define compile-omit-paths '("design" "demos"))
-(define test-omit-paths '("design" "demos"))
+(define test-omit-paths '("scribblings" "design" "demos"))

main.rkt

@@ -7,6 +7,8 @@
           ...
           ...+
 
+          #%host-expression
+
           mutable-reference-compiler
           immutable-reference-compiler
 
@@ -53,12 +55,14 @@
           free-identifiers
           binding-identifiers
           alpha-equivalent?
+          subst
           get-racket-referenced-identifiers))
 
 (require "private/syntax/interface.rkt"
          "private/runtime/compile.rkt"
          (for-syntax syntax/parse
                      (except-in "private/ee-lib/main.rkt" racket-var)
+                     "private/runtime/compile.rkt"
                      "private/ee-lib/persistent-id-table.rkt"
                      "private/ee-lib/binding.rkt"
                      "private/runtime/binding-operations.rkt"

private/ee-lib/flip-intro-scope.rkt

@@ -16,4 +16,6 @@
 
 (define/who (flip-intro-scope stx)
   (check who syntax? stx)
-  ((make-intro-scope-introducer) stx 'flip))
+  (if (syntax-transforming?)
+      ((make-intro-scope-introducer) stx 'flip)
+      stx))

private/ee-lib/persistent-id-table.rkt

@@ -32,7 +32,7 @@
 ; so entries wouldn't be available during module visit until the end of the module
 ; is reached.
 
-(struct persistent-free-id-table [persisted transient id])
+(struct persistent-free-id-table [persisted [transient #:mutable] id])
 
 (define (make-persistent-free-id-table id)
   (persistent-free-id-table
@@ -100,6 +100,9 @@
       #`(cons #'#,(flip-intro-scope k) #,(if (syntax? v)
                                              #`(deserialize-syntax-props #'#,(serialize-syntax-props (flip-intro-scope v)))
                                              #`'#,v))))
+  
+  (set-persistent-free-id-table-transient! t (make-free-id-table))
+  
   #`(begin-for-syntax
       (do-extension! #,(persistent-free-id-table-id t)
                      (list . #,alist))))

private/runtime/binding-operations.rkt

@@ -2,7 +2,9 @@
 
 (provide free-identifiers
          binding-identifiers
+         identifier=?
          alpha-equivalent?
+         subst
          get-racket-referenced-identifiers
          (rename-out [identifier=? compiled-identifier=?]))
 
@@ -99,25 +101,22 @@
 ; Syntax, Syntax [#:allow-host? Boolean] -> Boolean
 ; Are the two expressions alpha-equivalent?
 (define (alpha-equivalent? stx-a stx-b #:allow-host? [allow-host? #f])
-  (define bound-reference=? (alpha-equivalent?/bindings stx-a stx-b allow-host?))
+  (define bound-reference=? (syntaxes->bound-reference=? stx-a stx-b allow-host?))
   (and bound-reference=?
        (alpha-equivalent?/references stx-a stx-b bound-reference=? allow-host?)))
 
 ; Syntax Syntax Boolean -> (or/c #f (Identifier Identifier -> Boolean))
-; check that the bindings of both expressions can be alpha-equivalent.
-; returns bound-reference=?, or #f if the binding check fails.
-(define (alpha-equivalent?/bindings stx-a stx-b allow-host?)
+; if the two terms have corresponding binders, build bound-reference=?
+; If they have different numbers of binders, return #f
+; bound-reference=? answers "do these two references refer to corresponding binders?"
+(define (syntaxes->bound-reference=? stx-a stx-b allow-host?)
   (define table-a (make-free-id-table))
   (define table-b (make-free-id-table))
+  ;; associate both binders with the same gensym
   (define (bind! identifier-a identifier-b)
     (define x (gensym))
-    (free-id-table-set! table-a identifier-a x)
-    (free-id-table-set! table-b identifier-b x))
-  (define (bound-reference=? identifier-a identifier-b)
-    (and (dict-has-key? table-a identifier-a)
-         (dict-has-key? table-b identifier-b)
-         (eq? (free-id-table-ref table-a identifier-a)
-              (free-id-table-ref table-b identifier-b))))
+    (free-id-table-set! table-a (compiled-from identifier-a) x)
+    (free-id-table-set! table-b (compiled-from identifier-b) x))
   (define binders-a (binding-identifiers stx-a #:allow-host? allow-host?))
   (define binders-b (binding-identifiers stx-b #:allow-host? allow-host?))
   ; must traverse binders before references
@@ -127,7 +126,16 @@
         [binder-b binders-b])
     (bind! binder-a binder-b))
   (and (= (length binders-a) (length binders-b))
-       bound-reference=?))
+       (substitutions->bound-reference=? table-a table-b)))
+
+;; FreeIdTable FreeIdTable -> (Identifier Identifier -> Boolean)
+;; Do these two references refer to corresponding binders?
+;; table-a and table-b should map corresponding binders to the same, unique value
+(define ((substitutions->bound-reference=? table-a table-b) identifier-a identifier-b)
+  (and (dict-has-key? table-a (compiled-from identifier-a))
+       (dict-has-key? table-b (compiled-from identifier-b))
+       (eq? (free-id-table-ref table-a (compiled-from identifier-a))
+            (free-id-table-ref table-b (compiled-from identifier-b)))))
 
 ; Syntax Syntax (Identifier Identifier -> Boolean) Boolean -> Boolean
 ; check that the references are alpha-equivalent.
@@ -159,6 +167,22 @@
       [(a b) (equal? (syntax->datum #'a)
                      (syntax->datum #'b))])))
 
+;; Syntax Syntax Syntax -> Syntax
+;; Replace all occurrences of target (by alpha equivalence) with replacement in stx.
+;; Leaves host expressions unchanged.
+(define (subst stx target replacement)
+  (let loop ([stx stx])
+    (if (if (compiled-binder? target)
+            (and (compiled-reference? stx) (identifier=? stx target))
+            (alpha-equivalent? stx target))
+        replacement
+        (syntax-parse stx
+          ;; ignore host expressions
+          [((~literal #%host-expression) . _) this-syntax]
+          [(a . b)
+           (quasisyntax/loc this-syntax (#,(loop #'a) . #,(loop #'b)))]
+          [_ stx]))))
+
 (define current-referenced-vars (make-parameter #f))
 
 ; get the racket vars referenced in e of the provided binding classes
@@ -174,9 +198,7 @@
                   'expression
                   '())
 
-    (sequence->list (in-symbol-set (for/fold ([references (immutable-symbol-set)])
-                                             ([x (in-symbol-set (current-referenced-vars))])
-                                     (symbol-set-add references x))))))
+    (sequence->list (in-symbol-set (current-referenced-vars)))))
 
 (define recording-reference-compiler
   (make-variable-like-reference-compiler

private/syntax/interface.rkt

@@ -359,6 +359,9 @@
     ((~literal define-syntaxes) (x:racket-macro ...) e:expr)
     #:binding (export-syntaxes x ... e)
 
+    ((~literal begin) b:racket-body ...)
+    #:binding [(re-export b) ...]
+
     e:racket-expr))
 
 (define-syntax define-dsl-syntax