mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
c0f6c1638b
* module/rnrs/base.scm (error, assert): Define -- they were missing. (assertion-violation): Properly treat a #f `who' argument. * module/rnrs/conditions.scm (condition): Use `assertion-violation' instead of the undefined `raise'. (define-condition-type): Fix for multiple fields. * test-suite/tests/r6rs-conditions.test: Test accessors of a multiple-field condition. Also import `(rnrs base)' to allow stand-alone running of the tests; apparently the `@' references scattered throughout the R6RS modules make the libraries sensitive to their load order -- for instance, trying to load `(rnrs conditions)' before `(rnrs base)' is loaded fails. * module/rnrs/records/inspection.scm: Use `assertion-violation' instead of an explicit `raise'. * module/rnrs/records/syntactic.scm (process-fields): Use `syntax-violation' instead of bogus invocations of `error'.
258 lines
8.9 KiB
Scheme
258 lines
8.9 KiB
Scheme
;;; syntactic.scm --- Syntactic support for R6RS records
|
||
|
||
;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||
;;
|
||
;; 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
|
||
|
||
|
||
(library (rnrs records syntactic (6))
|
||
(export define-record-type
|
||
record-type-descriptor
|
||
record-constructor-descriptor)
|
||
(import (only (guile) *unspecified* and=> gensym unspecified?)
|
||
(rnrs base (6))
|
||
(rnrs conditions (6))
|
||
(rnrs exceptions (6))
|
||
(rnrs hashtables (6))
|
||
(rnrs lists (6))
|
||
(rnrs records procedural (6))
|
||
(rnrs syntax-case (6))
|
||
(only (srfi :1) take))
|
||
|
||
(define record-type-registry (make-eq-hashtable))
|
||
|
||
(define (guess-constructor-name record-name)
|
||
(string->symbol (string-append "make-" (symbol->string record-name))))
|
||
(define (guess-predicate-name record-name)
|
||
(string->symbol (string-append (symbol->string record-name) "?")))
|
||
(define (register-record-type name rtd rcd)
|
||
(hashtable-set! record-type-registry name (cons rtd rcd)))
|
||
(define (lookup-record-type-descriptor name)
|
||
(and=> (hashtable-ref record-type-registry name #f) car))
|
||
(define (lookup-record-constructor-descriptor name)
|
||
(and=> (hashtable-ref record-type-registry name #f) cdr))
|
||
|
||
(define-syntax define-record-type
|
||
(lambda (stx)
|
||
(syntax-case stx ()
|
||
((_ (record-name constructor-name predicate-name) record-clause ...)
|
||
#'(define-record-type0
|
||
(record-name constructor-name predicate-name)
|
||
record-clause ...))
|
||
((_ record-name record-clause ...)
|
||
(let* ((record-name-sym (syntax->datum #'record-name))
|
||
(constructor-name
|
||
(datum->syntax
|
||
#'record-name (guess-constructor-name record-name-sym)))
|
||
(predicate-name
|
||
(datum->syntax
|
||
#'record-name (guess-predicate-name record-name-sym))))
|
||
#`(define-record-type0
|
||
(record-name #,constructor-name #,predicate-name)
|
||
record-clause ...))))))
|
||
|
||
(define (sequence n)
|
||
(define (seq-inner n) (if (= n 0) '(0) (cons n (seq-inner (- n 1)))))
|
||
(reverse (seq-inner n)))
|
||
(define (number-fields fields)
|
||
(define (number-fields-inner fields counter)
|
||
(if (null? fields)
|
||
'()
|
||
(cons (cons fields counter)
|
||
(number-fields-inner (cdr fields) (+ counter 1)))))
|
||
(number-fields-inner fields 0))
|
||
|
||
(define (process-fields record-name fields)
|
||
(define record-name-str (symbol->string record-name))
|
||
(define (guess-accessor-name field-name)
|
||
(string->symbol (string-append
|
||
record-name-str "-" (symbol->string field-name))))
|
||
(define (guess-mutator-name field-name)
|
||
(string->symbol
|
||
(string-append
|
||
record-name-str "-" (symbol->string field-name) "-set!")))
|
||
|
||
(define (f x)
|
||
(define (lose)
|
||
(syntax-violation 'define-record-type "invalid field specifier" x))
|
||
(cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
|
||
((not (list? x)) (lose))
|
||
((eq? (car x) 'immutable)
|
||
(cons 'immutable
|
||
(case (length x)
|
||
((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
|
||
((3) (list (cadr x) (caddr x) #f))
|
||
(else (lose)))))
|
||
((eq? (car x) 'mutable)
|
||
(cons 'mutable
|
||
(case (length x)
|
||
((2) (list (cadr x)
|
||
(guess-accessor-name (cadr x))
|
||
(guess-mutator-name (cadr x))))
|
||
((4) (cdr x))
|
||
(else (lose)))))
|
||
(else (lose))))
|
||
(map f fields))
|
||
|
||
(define-syntax define-record-type0
|
||
(lambda (stx)
|
||
(syntax-case stx ()
|
||
((_ (record-name constructor-name predicate-name) record-clause ...)
|
||
(let loop ((fields *unspecified*)
|
||
(parent *unspecified*)
|
||
(protocol *unspecified*)
|
||
(sealed *unspecified*)
|
||
(opaque *unspecified*)
|
||
(nongenerative *unspecified*)
|
||
(constructor *unspecified*)
|
||
(parent-rtd *unspecified*)
|
||
(record-clauses (syntax->datum #'(record-clause ...))))
|
||
(if (null? record-clauses)
|
||
(let*
|
||
((fields (if (unspecified? fields) '() fields))
|
||
(field-names
|
||
(datum->syntax
|
||
#'record-name
|
||
(list->vector (map (lambda (x) (take x 2)) fields))))
|
||
(field-accessors
|
||
(fold-left (lambda (x c lst)
|
||
(cons #`(define #,(datum->syntax
|
||
#'record-name (caddr x))
|
||
(record-accessor record-name #,c))
|
||
lst))
|
||
'() fields (sequence (length fields))))
|
||
(field-mutators
|
||
(fold-left (lambda (x c lst)
|
||
(if (cadddr x)
|
||
(cons #`(define #,(datum->syntax
|
||
#'record-name (cadddr x))
|
||
(record-mutator record-name #,c))
|
||
lst)
|
||
lst))
|
||
'() fields (sequence (length fields))))
|
||
|
||
(parent-cd
|
||
(datum->syntax
|
||
stx (cond ((not (unspecified? parent))
|
||
`(record-constructor-descriptor ,parent))
|
||
((not (unspecified? parent-rtd)) (cadr parent-rtd))
|
||
(else #f))))
|
||
(parent-rtd
|
||
(datum->syntax
|
||
stx (cond ((not (unspecified? parent))
|
||
`(record-type-descriptor ,parent))
|
||
((not (unspecified? parent-rtd)) (car parent-rtd))
|
||
(else #f))))
|
||
|
||
(protocol (datum->syntax
|
||
#'record-name (if (unspecified? protocol)
|
||
#f protocol)))
|
||
(uid (datum->syntax
|
||
#'record-name (if (unspecified? nongenerative)
|
||
#f nongenerative)))
|
||
(sealed? (if (unspecified? sealed) #f sealed))
|
||
(opaque? (if (unspecified? opaque) #f opaque))
|
||
|
||
(record-name-sym (datum->syntax
|
||
stx (list 'quote
|
||
(syntax->datum #'record-name)))))
|
||
|
||
#`(begin
|
||
(define record-name
|
||
(make-record-type-descriptor
|
||
#,record-name-sym
|
||
#,parent-rtd #,uid #,sealed? #,opaque?
|
||
#,field-names))
|
||
(define constructor-name
|
||
(record-constructor
|
||
(make-record-constructor-descriptor
|
||
record-name #,parent-cd #,protocol)))
|
||
(define dummy
|
||
(let ()
|
||
(register-record-type
|
||
#,record-name-sym
|
||
record-name (make-record-constructor-descriptor
|
||
record-name #,parent-cd #,protocol))
|
||
'dummy))
|
||
(define predicate-name (record-predicate record-name))
|
||
#,@field-accessors
|
||
#,@field-mutators))
|
||
(let ((cr (car record-clauses)))
|
||
(case (car cr)
|
||
((fields)
|
||
(if (unspecified? fields)
|
||
(loop (process-fields (syntax->datum #'record-name)
|
||
(cdr cr))
|
||
parent protocol sealed opaque nongenerative
|
||
constructor parent-rtd (cdr record-clauses))
|
||
(raise (make-assertion-violation))))
|
||
((parent)
|
||
(if (not (unspecified? parent-rtd))
|
||
(raise (make-assertion-violation)))
|
||
(if (unspecified? parent)
|
||
(loop fields (cadr cr) protocol sealed opaque
|
||
nongenerative constructor parent-rtd
|
||
(cdr record-clauses))
|
||
(raise (make-assertion-violation))))
|
||
((protocol)
|
||
(if (unspecified? protocol)
|
||
(loop fields parent (cadr cr) sealed opaque
|
||
nongenerative constructor parent-rtd
|
||
(cdr record-clauses))
|
||
(raise (make-assertion-violation))))
|
||
((sealed)
|
||
(if (unspecified? sealed)
|
||
(loop fields parent protocol (cadr cr) opaque
|
||
nongenerative constructor parent-rtd
|
||
(cdr record-clauses))
|
||
(raise (make-assertion-violation))))
|
||
((opaque) (if (unspecified? opaque)
|
||
(loop fields parent protocol sealed (cadr cr)
|
||
nongenerative constructor parent-rtd
|
||
(cdr record-clauses))
|
||
(raise (make-assertion-violation))))
|
||
((nongenerative)
|
||
(if (unspecified? nongenerative)
|
||
(let ((uid (list 'quote
|
||
(or (and (> (length cr) 1) (cadr cr))
|
||
(gensym)))))
|
||
(loop fields parent protocol sealed
|
||
opaque uid constructor
|
||
parent-rtd (cdr record-clauses)))
|
||
(raise (make-assertion-violation))))
|
||
((parent-rtd)
|
||
(if (not (unspecified? parent))
|
||
(raise (make-assertion-violation)))
|
||
(if (unspecified? parent-rtd)
|
||
(loop fields parent protocol sealed opaque
|
||
nongenerative constructor (cdr cr)
|
||
(cdr record-clauses))
|
||
(raise (make-assertion-violation))))
|
||
(else (raise (make-assertion-violation)))))))))))
|
||
|
||
(define-syntax record-type-descriptor
|
||
(lambda (stx)
|
||
(syntax-case stx ()
|
||
((_ name) #`(lookup-record-type-descriptor
|
||
#,(datum->syntax
|
||
stx (list 'quote (syntax->datum #'name))))))))
|
||
|
||
(define-syntax record-constructor-descriptor
|
||
(lambda (stx)
|
||
(syntax-case stx ()
|
||
((_ name) #`(lookup-record-constructor-descriptor
|
||
#,(datum->syntax
|
||
stx (list 'quote (syntax->datum #'name))))))))
|
||
)
|