mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Improve error for set-fields paths leading to different types.

Browse source 
* module/system/base/ck.scm: New module.

* module/srfi/srfi-9.scm: Import (system base ck).

  (getter-type, getter-index, getter-copier): Convert incoming argument
  convention to CK form.

  (define-tagged-inlinable): Convert return value convention for key
  lookup to CK form.

* module/srfi/srfi-9/gnu.scm: Import (system base ck).
  Rename '%set-fields-unknown-getter' to 'unknown-getter'.

  (c-list, c-same-type-check): New macros.

  (%set-fields): Using the CK abstract machine, arrange to check (at
  macro expansion time) that all of the getters in head position
  correspond to the same record type.

* test-suite/tests/srfi-9.test: Add test.
This commit is contained in:
Mark H Weaver 2012-11-09 05:04:13 -05:00
parent f31a076232
commit 92fac8c056
4 changed files with 164 additions and 26 deletions
Download patch file Download diff file Expand all files Collapse all files

21
module/srfi/srfi-9.scm
View file

@ -60,6 +60,7 @@
(define-module (srfi srfi-9)
#:use-module (srfi srfi-1)
#:use-module (system base ck)
#:export (define-record-type))
(cond-expand-provide (current-module) '(srfi-9))
@ -81,16 +82,22 @@
(define-syntax-rule (%%on-error err) err)
(define %%type #f) ; a private syntax literal
(define-syntax-rule (getter-type getter err)
(getter (%%on-error err) %%type))
(define-syntax getter-type
(syntax-rules (quote)
((_ s 'getter 'err)
(getter (%%on-error err) %%type s))))
(define %%index #f) ; a private syntax literal
(define-syntax-rule (getter-index getter err)
(getter (%%on-error err) %%index))
(define-syntax getter-index
(syntax-rules (quote)
((_ s 'getter 'err)
(getter (%%on-error err) %%index s))))
(define %%copier #f) ; a private syntax literal
(define-syntax-rule (getter-copier getter err)
(getter (%%on-error err) %%copier))
(define-syntax getter-copier
(syntax-rules (quote)
((_ s 'getter 'err)
(getter (%%on-error err) %%copier s))))
(define-syntax define-tagged-inlinable
(lambda (x)
@ -110,7 +117,7 @@
(define-syntax name
(lambda (x)
(syntax-case x (%%on-error key ...)
((_ (%%on-error err) key) #'value) ...
((_ (%%on-error err) key s) #'(ck s 'value)) ...
((_ args ...)
#'((lambda (formals ...)
body ...)

78
module/srfi/srfi-9/gnu.scm
View file

@ -24,6 +24,7 @@
(define-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-1)
#:use-module (system base ck)
#:export (set-record-type-printer!
define-immutable-record-type
set-field
@ -76,12 +77,41 @@
(with-syntax (((((head . tail) expr) ...) specs))
(fold insert '() #'(head ...) #'(tail ...) #'(expr ...))))
(define-syntax %set-fields-unknown-getter
(define-syntax unknown-getter
(lambda (x)
(syntax-case x ()
((_ orig-form getter)
(syntax-violation 'set-fields "unknown getter" #'orig-form #'getter)))))
(define-syntax c-list
(lambda (x)
(syntax-case x (quote)
((_ s 'v ...)
#'(ck s '(v ...))))))
(define-syntax c-same-type-check
(lambda (x)
(syntax-case x (quote)
((_ s 'orig-form '(path ...)
'(getter0 getter ...)
'(type0 type ...)
'on-success)
(every (lambda (t g)
(or (free-identifier=? t #'type0)
(syntax-violation
'set-fields
(format #f
"\
field paths ~a and ~a require one object to belong to two different record types (~a and ~a)"
(syntax->datum #`(path ... #,g))
(syntax->datum #'(path ... getter0))
(syntax->datum t)
(syntax->datum #'type0))
#'orig-form)))
#'(type ...)
#'(getter ...))
#'(ck s 'on-success)))))
(define-syntax %set-fields
(lambda (x)
(with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type))
@ -98,24 +128,34 @@
struct-expr ((head . tail) expr) ...)
(let ((collated-specs (collate-set-field-specs
#'(((head . tail) expr) ...))))
(with-syntax ((getter (caar collated-specs)))
(with-syntax ((err #'(%set-fields-unknown-getter
orig-form getter)))
#`(let ((s struct-expr))
((getter-copier getter err)
check?
s
#,@(map (lambda (spec)
(with-syntax (((head (tail expr) ...) spec))
(with-syntax ((err #'(%set-fields-unknown-getter
orig-form head)))
#'(head (%set-fields
check?
orig-form
(path-so-far ... head)
(struct-ref s (getter-index head err))
(tail expr) ...)))))
collated-specs)))))))
(with-syntax (((getter0 getter ...)
(map car collated-specs)))
(with-syntax ((err #'(unknown-getter
orig-form getter0)))
#`(ck
()
(c-same-type-check
'orig-form
'(path-so-far ...)
'(getter0 getter ...)
(c-list (getter-type 'getter0 'err)
(getter-type 'getter 'err) ...)
'(let ((s struct-expr))
((ck () (getter-copier 'getter0 'err))
check?
s
#,@(map (lambda (spec)
(with-syntax (((head (tail expr) ...) spec))
(with-syntax ((err #'(unknown-getter
orig-form head)))
#'(head (%set-fields
check?
orig-form
(path-so-far ... head)
(struct-ref s (ck () (getter-index
'head 'err)))
(tail expr) ...)))))
collated-specs)))))))))
((_ check? orig-form (path-so-far ...)
s (() e) (() e*) ...)
(syntax-violation 'set-fields "duplicate field path"

55
module/system/base/ck.scm Normal file
View file

@ -0,0 +1,55 @@
;;; ck, to facilitate applicative-order macro programming
;;; Copyright (C) 2012 Free Software Foundation, Inc
;;; Copyright (C) 2009, 2011 Oleg Kiselyov
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;
;;;
;;; Originally written by Oleg Kiselyov and later contributed to Guile.
;;;
;;; Based on the CK machine introduced in:
;;;
;;; Matthias Felleisen and Daniel P. Friedman: Control operators, the
;;; SECD machine, and the lambda-calculus. In Martin Wirsing, editor,
;;; Formal Description of Programming Concepts III, pages
;;; 193-217. Elsevier, Amsterdam, 1986.
;;;
;;; See http://okmij.org/ftp/Scheme/macros.html#ck-macros for details.
;;;
(define-module (system base ck)
#:export (ck))
(define-syntax ck
(syntax-rules (quote)
((ck () 'v) v) ; yield the value on empty stack
((ck (((op ...) ea ...) . s) 'v) ; re-focus on the other argument, ea
(ck-arg s (op ... 'v) ea ...))
((ck s (op ea ...)) ; Focus: handling an application;
(ck-arg s (op) ea ...)))) ; check if args are values
(define-syntax ck-arg
(syntax-rules (quote)
((ck-arg s (op va ...)) ; all arguments are evaluated,
(op s va ...)) ; do the redex
((ck-arg s (op ...) 'v ea1 ...) ; optimization when the first ea
(ck-arg s (op ... 'v) ea1 ...)) ; was already a value
((ck-arg s (op ...) ea ea1 ...) ; focus on ea, to evaluate it
(ck (((op ...) ea1 ...) . s) ea))))

36
test-suite/tests/srfi-9.test
View file

@ -607,6 +607,42 @@
((bar-i) 3))))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(list key whom what form subform))))
(pass-if-equal "incompatible field paths"
'(syntax-error set-fields
"\
field paths (bar-i bar-j) and (bar-i foo-x) require one object \
to belong to two different record types (:bar and foo)"
(set-fields s
((bar-i foo-x) 1)
((bar-i bar-j) 2)
((bar-j) 3))
#f)
(catch 'syntax-error
(lambda ()
(compile '(let ()
(define-immutable-record-type foo
(make-foo x)
foo?
(x foo-x)
(y foo-y set-foo-y)
(z foo-z set-foo-z))
(define-immutable-record-type :bar
(make-bar i j)
bar?
(i bar-i)
(j bar-j set-bar-j))
(let ((s (make-bar (make-foo 5) 2)))
(set-fields s
((bar-i foo-x) 1)
((bar-i bar-j) 2)
((bar-j) 3))))
#:env (current-module))
#f)
(lambda (key whom what src form subform)
(list key whom what form subform))))))