compile-psyntax.scm 7.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183
  1. ;;; -*- mode: scheme; coding: utf-8; -*-
  2. ;;;
  3. ;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2021 Free Software Foundation, Inc.
  4. ;;;
  5. ;;; This library is free software; you can redistribute it and/or
  6. ;;; modify it under the terms of the GNU Lesser General Public
  7. ;;; License as published by the Free Software Foundation; either
  8. ;;; version 3 of the License, or (at your option) any later version.
  9. ;;;
  10. ;;; This library is distributed in the hope that it will be useful,
  11. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  13. ;;; Lesser General Public License for more details.
  14. ;;;
  15. ;;; You should have received a copy of the GNU Lesser General Public
  16. ;;; License along with this library; if not, write to the Free Software
  17. ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18. (use-modules (language tree-il)
  19. (language tree-il primitives)
  20. (srfi srfi-1)
  21. (ice-9 control)
  22. (ice-9 pretty-print)
  23. (system syntax internal))
  24. ;; Minimize a syntax-object such that it can no longer be used as the
  25. ;; first argument to 'datum->syntax', but is otherwise equivalent.
  26. (define (squeeze-syntax-object syn)
  27. (define (ensure-list x) (if (vector? x) (vector->list x) x))
  28. (let ((x (syntax-expression syn))
  29. (wrap (syntax-wrap syn))
  30. (mod (syntax-module syn)))
  31. (let ((marks (car wrap))
  32. (subst (cdr wrap)))
  33. (define (squeeze-wrap marks subst)
  34. (make-syntax x (cons marks subst) mod))
  35. (cond
  36. ((symbol? x)
  37. (let loop ((marks marks) (subst subst))
  38. (cond
  39. ((null? subst) (squeeze-wrap marks subst))
  40. ((eq? 'shift (car subst)) (loop (cdr marks) (cdr subst)))
  41. ((find (lambda (entry) (and (eq? x (car entry))
  42. (equal? marks (cadr entry))))
  43. (apply map list (map ensure-list
  44. (cdr (vector->list (car subst))))))
  45. => (lambda (entry)
  46. (squeeze-wrap marks
  47. (list (list->vector
  48. (cons 'ribcage
  49. (map vector entry)))))))
  50. (else (loop marks (cdr subst))))))
  51. ((or (pair? x) (vector? x)) syn)
  52. (else x)))))
  53. (define (squeeze-constant x)
  54. (cond ((syntax? x) (squeeze-syntax-object x))
  55. ((pair? x)
  56. (cons (squeeze-constant (car x))
  57. (squeeze-constant (cdr x))))
  58. ((vector? x)
  59. (list->vector (squeeze-constant (vector->list x))))
  60. (else x)))
  61. (define (squeeze-tree-il x)
  62. (post-order (lambda (x)
  63. (if (const? x)
  64. (make-const (const-src x)
  65. (squeeze-constant (const-exp x)))
  66. x))
  67. x))
  68. (define (translate-literal-syntax-objects x)
  69. (define (find-make-syntax-lexical-binding x)
  70. (let/ec return
  71. (pre-order (lambda (x)
  72. (when (let? x)
  73. (for-each (lambda (name sym)
  74. (when (eq? name 'make-syntax)
  75. (return sym)))
  76. (let-names x) (let-gensyms x)))
  77. x)
  78. x)
  79. #f))
  80. (let ((make-syntax-gensym (find-make-syntax-lexical-binding x))
  81. (retry-tag (make-prompt-tag)))
  82. (define (translate-constant x)
  83. (let ((src (const-src x))
  84. (exp (const-exp x)))
  85. (cond
  86. ((list? exp)
  87. (let ((exp (map (lambda (x)
  88. (translate-constant (make-const src x)))
  89. exp)))
  90. (if (and-map const? exp)
  91. x
  92. (make-primcall src 'list exp))))
  93. ((pair? exp)
  94. (let ((car (translate-constant (make-const src (car exp))))
  95. (cdr (translate-constant (make-const src (cdr exp)))))
  96. (if (and (const? car) (const? cdr))
  97. x
  98. (make-primcall src 'cons (list car cdr)))))
  99. ((vector? exp)
  100. (let ((exp (map (lambda (x)
  101. (translate-constant (make-const src x)))
  102. (vector->list exp))))
  103. (if (and-map const? exp)
  104. x
  105. (make-primcall src 'vector exp))))
  106. ((syntax? exp)
  107. (make-call src
  108. (if make-syntax-gensym
  109. (make-lexical-ref src 'make-syntax
  110. make-syntax-gensym)
  111. (abort-to-prompt retry-tag))
  112. (list
  113. (translate-constant
  114. (make-const src (syntax-expression exp)))
  115. (translate-constant
  116. (make-const src (syntax-wrap exp)))
  117. (translate-constant
  118. (make-const src (syntax-module exp))))))
  119. (else x))))
  120. (call-with-prompt retry-tag
  121. (lambda ()
  122. (post-order (lambda (x)
  123. (if (const? x)
  124. (translate-constant x)
  125. x))
  126. x))
  127. (lambda (k)
  128. ;; OK, we have a syntax object embedded in this code, but
  129. ;; make-syntax isn't lexically bound. This is the case for the
  130. ;; top-level macro definitions in psyntax that follow the main
  131. ;; let blob. Attach a lexical binding and retry.
  132. (unless (toplevel-define? x) (error "unexpected"))
  133. (translate-literal-syntax-objects
  134. (make-toplevel-define
  135. (toplevel-define-src x)
  136. (toplevel-define-mod x)
  137. (toplevel-define-name x)
  138. (make-let (toplevel-define-src x)
  139. (list 'make-syntax)
  140. (list (module-gensym))
  141. (list (make-toplevel-ref #f #f 'make-syntax))
  142. (toplevel-define-exp x))))))))
  143. ;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
  144. ;; changing session identifiers.
  145. (set! syntax-session-id (lambda () "*"))
  146. (let ((source (list-ref (command-line) 1))
  147. (target (list-ref (command-line) 2)))
  148. (let ((in (open-input-file source))
  149. (out (open-output-file (string-append target ".tmp"))))
  150. (write '(eval-when (compile) (set-current-module (resolve-module '(guile))))
  151. out)
  152. (newline out)
  153. (let loop ((x (read in)))
  154. (if (eof-object? x)
  155. (begin
  156. (close-port out)
  157. (close-port in))
  158. (begin
  159. (pretty-print (tree-il->scheme
  160. (translate-literal-syntax-objects
  161. (squeeze-tree-il
  162. (resolve-primitives
  163. (macroexpand x 'c '(compile load eval))
  164. (current-module))))
  165. (current-module)
  166. (list #:avoid-lambda? #f
  167. #:use-case? #f
  168. #:strip-numeric-suffixes? #t
  169. #:use-derived-syntax?
  170. (and (pair? x)
  171. (eq? 'let (car x)))))
  172. out #:width 120 #:max-expr-width 70)
  173. (newline out)
  174. (loop (read in))))))
  175. (system (format #f "mv -f ~s.tmp ~s" target target)))