syntax.scm 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300
  1. ;;; Guile VM specific syntaxes and utilities
  2. ;; Copyright (C) 2001, 2009, 2016, 2019 Free Software Foundation, Inc
  3. ;;; This library is free software; you can redistribute it and/or
  4. ;;; modify it under the terms of the GNU Lesser General Public
  5. ;;; License as published by the Free Software Foundation; either
  6. ;;; version 3 of the License, or (at your option) any later version.
  7. ;;;
  8. ;;; This library is distributed in the hope that it will be useful,
  9. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;;; Lesser General Public License for more details.
  12. ;;;
  13. ;;; You should have received a copy of the GNU Lesser General Public
  14. ;;; License along with this library; if not, write to the Free Software
  15. ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;; Code:
  17. (define-module (system base syntax)
  18. #:export (%compute-initargs)
  19. #:export-syntax (define-type define-record define-record/keywords
  20. record-case transform-record))
  21. (define (symbol-trim-both sym pred)
  22. (string->symbol (string-trim-both (symbol->string sym) pred)))
  23. (define (trim-brackets sym)
  24. (symbol-trim-both sym (list->char-set '(#\< #\>))))
  25. ;;;
  26. ;;; Type
  27. ;;;
  28. (define-macro (define-type name . rest)
  29. (let ((name (if (pair? name) (car name) name))
  30. (opts (if (pair? name) (cdr name) '())))
  31. (let ((printer (kw-arg-ref opts #:printer))
  32. (common-slots (or (kw-arg-ref opts #:common-slots) '())))
  33. `(begin ,@(map (lambda (def)
  34. `(define-record ,(if printer
  35. `(,(car def) ,printer)
  36. (car def))
  37. ,@common-slots
  38. ,@(cdr def)))
  39. rest)
  40. ,@(map (lambda (common-slot i)
  41. `(define ,(symbol-append (trim-brackets name)
  42. '- common-slot)
  43. (make-procedure-with-setter
  44. (lambda (x) (struct-ref x ,i))
  45. (lambda (x v) (struct-set! x ,i v)))))
  46. common-slots (iota (length common-slots)))))))
  47. ;;;
  48. ;;; Record
  49. ;;;
  50. (define-macro (define-record name-form . slots)
  51. (let* ((name (if (pair? name-form) (car name-form) name-form))
  52. (printer (and (pair? name-form) (cadr name-form)))
  53. (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
  54. slots))
  55. (stem (trim-brackets name)))
  56. `(begin
  57. (define ,name (make-record-type ',name ',slot-names
  58. ,@(if printer (list printer) '())))
  59. ,(let* ((reqs (let lp ((slots slots))
  60. (if (or (null? slots) (not (symbol? (car slots))))
  61. '()
  62. (cons (car slots) (lp (cdr slots))))))
  63. (opts (list-tail slots (length reqs)))
  64. (tail (module-gensym "defrec")))
  65. `(define (,(symbol-append 'make- stem) ,@reqs . ,tail)
  66. (let ,(map (lambda (o)
  67. `(,(car o) (cond ((null? ,tail) ,(cadr o))
  68. (else (let ((_x (car ,tail)))
  69. (set! ,tail (cdr ,tail))
  70. _x)))))
  71. opts)
  72. (make-struct/no-tail ,name ,@slot-names))))
  73. (define ,(symbol-append stem '?) (record-predicate ,name))
  74. ,@(map (lambda (sname)
  75. `(define ,(symbol-append stem '- sname)
  76. (make-procedure-with-setter
  77. (record-accessor ,name ',sname)
  78. (record-modifier ,name ',sname))))
  79. slot-names))))
  80. ;; like the former, but accepting keyword arguments in addition to
  81. ;; optional arguments
  82. (define-macro (define-record/keywords name-form . slots)
  83. (let* ((name (if (pair? name-form) (car name-form) name-form))
  84. (printer (and (pair? name-form) (cadr name-form)))
  85. (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
  86. slots))
  87. (stem (trim-brackets name)))
  88. `(begin
  89. (define ,name (make-record-type ',name ',slot-names
  90. ,@(if printer (list printer) '())))
  91. (define ,(symbol-append 'make- stem)
  92. (let ((slots (list ,@(map (lambda (slot)
  93. (if (pair? slot)
  94. `(cons ',(car slot) ,(cadr slot))
  95. `',slot))
  96. slots)))
  97. (constructor (record-constructor ,name)))
  98. (lambda args
  99. (apply constructor (%compute-initargs args slots)))))
  100. (define ,(symbol-append stem '?) (record-predicate ,name))
  101. ,@(map (lambda (sname)
  102. `(define ,(symbol-append stem '- sname)
  103. (make-procedure-with-setter
  104. (record-accessor ,name ',sname)
  105. (record-modifier ,name ',sname))))
  106. slot-names))))
  107. (define (%compute-initargs args slots)
  108. (define (finish out)
  109. (map (lambda (slot)
  110. (let ((name (if (pair? slot) (car slot) slot)))
  111. (cond ((assq name out) => cdr)
  112. ((pair? slot) (cdr slot))
  113. (else (error "unbound slot" args slots name)))))
  114. slots))
  115. (let lp ((in args) (positional slots) (out '()))
  116. (cond
  117. ((null? in)
  118. (finish out))
  119. ((keyword? (car in))
  120. (let ((sym (keyword->symbol (car in))))
  121. (cond
  122. ((and (not (memq sym slots))
  123. (not (assq sym (filter pair? slots))))
  124. (error "unknown slot" sym))
  125. ((assq sym out) (error "slot already set" sym out))
  126. (else (lp (cddr in) '() (acons sym (cadr in) out))))))
  127. ((null? positional)
  128. (error "too many initargs" args slots))
  129. (else
  130. (lp (cdr in) (cdr positional)
  131. (let ((slot (car positional)))
  132. (acons (if (pair? slot) (car slot) slot)
  133. (car in)
  134. out)))))))
  135. ;;; FIXME: Re-write uses of `record-case' to use `match' instead.
  136. (define-syntax record-case
  137. (lambda (x)
  138. (syntax-case x ()
  139. ((_ record clause ...)
  140. (let ((r (syntax r))
  141. (rtd (syntax rtd)))
  142. (define (process-clause tag fields exprs)
  143. (let ((infix (trim-brackets (syntax->datum tag))))
  144. (with-syntax ((tag tag)
  145. (((f . accessor) ...)
  146. (let lp ((fields fields))
  147. (syntax-case fields ()
  148. (() (syntax ()))
  149. (((v0 f0) f1 ...)
  150. (acons (syntax v0)
  151. (datum->syntax x
  152. (symbol-append infix '- (syntax->datum
  153. (syntax f0))))
  154. (lp (syntax (f1 ...)))))
  155. ((f0 f1 ...)
  156. (acons (syntax f0)
  157. (datum->syntax x
  158. (symbol-append infix '- (syntax->datum
  159. (syntax f0))))
  160. (lp (syntax (f1 ...))))))))
  161. ((e0 e1 ...)
  162. (syntax-case exprs ()
  163. (() (syntax (#t)))
  164. ((e0 e1 ...) (syntax (e0 e1 ...))))))
  165. (syntax
  166. ((eq? rtd tag)
  167. (let ((f (accessor r))
  168. ...)
  169. e0 e1 ...))))))
  170. (with-syntax
  171. ((r r)
  172. (rtd rtd)
  173. ((processed ...)
  174. (let lp ((clauses (syntax (clause ...)))
  175. (out '()))
  176. (syntax-case clauses (else)
  177. (()
  178. (reverse! (cons (syntax
  179. (else (error "unhandled record" r)))
  180. out)))
  181. (((else e0 e1 ...))
  182. (reverse! (cons (syntax (else e0 e1 ...)) out)))
  183. (((else e0 e1 ...) . rest)
  184. (syntax-violation 'record-case
  185. "bad else clause placement"
  186. (syntax x)
  187. (syntax (else e0 e1 ...))))
  188. ((((<foo> f0 ...) e0 ...) . rest)
  189. (lp (syntax rest)
  190. (cons (process-clause (syntax <foo>)
  191. (syntax (f0 ...))
  192. (syntax (e0 ...)))
  193. out)))))))
  194. (syntax
  195. (let* ((r record)
  196. (rtd (struct-vtable r)))
  197. (cond processed ...)))))))))
  198. ;; Here we take the terrorism to another level. Nasty, but the client
  199. ;; code looks good.
  200. (define-macro (transform-record type-and-common record . clauses)
  201. (let ((r (module-gensym "rec"))
  202. (rtd (module-gensym "rtd"))
  203. (type-stem (trim-brackets (car type-and-common))))
  204. (define (make-stem s)
  205. (symbol-append type-stem '- s))
  206. (define (further-predicates x record-stem slots)
  207. (define (access slot)
  208. `(,(symbol-append (make-stem record-stem) '- slot) ,x))
  209. (let lp ((in slots) (out '()))
  210. (cond ((null? in) out)
  211. ((pair? (car in))
  212. (let ((slot (caar in))
  213. (arg (cadar in)))
  214. (cond ((symbol? arg)
  215. (lp (cdr in) out))
  216. ((pair? arg)
  217. (lp (cdr in)
  218. (append (further-predicates (access slot)
  219. (car arg)
  220. (cdr arg))
  221. out)))
  222. (else (lp (cdr in) (cons `(eq? ,(access slot) ',arg)
  223. out))))))
  224. (else (lp (cdr in) out)))))
  225. (define (let-clauses x record-stem slots)
  226. (define (access slot)
  227. `(,(symbol-append (make-stem record-stem) '- slot) ,x))
  228. (let lp ((in slots) (out '()))
  229. (cond ((null? in) out)
  230. ((pair? (car in))
  231. (let ((slot (caar in))
  232. (arg (cadar in)))
  233. (cond ((symbol? arg)
  234. (lp (cdr in)
  235. (cons `(,arg ,(access slot)) out)))
  236. ((pair? arg)
  237. (lp (cdr in)
  238. (append (let-clauses (access slot)
  239. (car arg)
  240. (cdr arg))
  241. out)))
  242. (else
  243. (lp (cdr in) out)))))
  244. (else
  245. (lp (cdr in)
  246. (cons `(,(car in) ,(access (car in))) out))))))
  247. (define (transform-expr x)
  248. (cond ((not (pair? x)) x)
  249. ((eq? (car x) '->)
  250. (if (= (length x) 2)
  251. (let ((form (cadr x)))
  252. `(,(symbol-append 'make- (make-stem (car form)))
  253. ,@(cdr type-and-common)
  254. ,@(map (lambda (y)
  255. (if (and (pair? y) (eq? (car y) 'unquote))
  256. (transform-expr (cadr y))
  257. y))
  258. (cdr form))))
  259. (error "bad -> form" x)))
  260. (else (cons (car x) (map transform-expr (cdr x))))))
  261. (define (process-clause clause)
  262. (if (eq? (car clause) 'else)
  263. clause
  264. (let ((stem (caar clause))
  265. (slots (cdar clause))
  266. (body (cdr clause)))
  267. (let ((record-type (symbol-append '< (make-stem stem) '>)))
  268. `((and (eq? ,rtd ,record-type)
  269. ,@(reverse (further-predicates r stem slots)))
  270. (let ,(reverse (let-clauses r stem slots))
  271. ,@(if (pair? body)
  272. (map transform-expr body)
  273. '((if #f #f)))))))))
  274. `(let* ((,r ,record)
  275. (,rtd (struct-vtable ,r))
  276. ,@(map (lambda (slot)
  277. `(,slot (,(make-stem slot) ,r)))
  278. (cdr type-and-common)))
  279. (cond ,@(let ((clauses (map process-clause clauses)))
  280. (if (assq 'else clauses)
  281. clauses
  282. (append clauses `((else (error "unhandled record" ,r))))))))))