Massage syntax of `define-record-procedures-parametric'.
Now (define-record-procedures-parametric pare pare-of make-pare pare? (pare-one pare-two)) instead of the old (define-record-procedures-parametric (pare a b) make-pare pare? (pare-one pare-two)) svn: r16035
This commit is contained in:
Mike Sperber
parent
34d365d3a8
commit
698199d68c
|
|
@ -1,5 +1,3 @@
|
|||
;; (define-record-procedures-2 :pare kons pare? ((kar set-kar!) kdr))
|
||||
|
||||
(define-syntax define-record-procedures*
|
||||
|
||||
(let ()
|
||||
|
|
@ -28,18 +26,14 @@
|
|||
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ ?type-spec
|
||||
((_ ?type-name
|
||||
?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
(?field-spec ...))
|
||||
|
||||
(with-syntax
|
||||
((?type-name (syntax-case #'?type-spec ()
|
||||
((?id ?param ...)
|
||||
#'?id)
|
||||
(?id
|
||||
#'?id)))
|
||||
((accessor ...)
|
||||
(((accessor ...)
|
||||
(map (lambda (field-spec)
|
||||
(syntax-case field-spec ()
|
||||
((accessor mutator) (syntax accessor))
|
||||
|
|
@ -142,23 +136,22 @@
|
|||
accessor-proc ...
|
||||
mutator-proc ...))))
|
||||
(contract
|
||||
(syntax-case #'?type-spec ()
|
||||
((_ ?param ...)
|
||||
(with-syntax (((component-contract ...)
|
||||
(map (lambda (accessor param)
|
||||
(with-syntax ((?accessor accessor)
|
||||
(?param param))
|
||||
#'(at ?param (property ?accessor ?param))))
|
||||
(syntax->list #'(our-accessor ...))
|
||||
(syntax->list #'(?param ...)))))
|
||||
#'(define ?type-spec
|
||||
(contract
|
||||
(combined (at ?type-name (predicate real-predicate))
|
||||
component-contract ...)))))
|
||||
(_
|
||||
;; we use real-predicate to avoid infinite recursion if a contract
|
||||
;; for ?type-name using ?predicate is inadvertently defined
|
||||
#'(define ?type-name (contract (predicate real-predicate)))))))
|
||||
(with-syntax (((?param ...) (generate-temporaries #'(?field-spec ...))))
|
||||
(with-syntax (((component-contract ...)
|
||||
(map (lambda (accessor param)
|
||||
(with-syntax ((?accessor accessor)
|
||||
(?param param))
|
||||
#'(at ?param (property ?accessor ?param))))
|
||||
(syntax->list #'(our-accessor ...))
|
||||
(syntax->list #'(?param ...)))))
|
||||
#'(begin
|
||||
;; we use real-predicate to avoid infinite recursion if a contract
|
||||
;; for ?type-name using ?predicate is inadvertently defined
|
||||
(define ?type-name (contract (predicate real-predicate)))
|
||||
(define (?contract-constructor-name ?param ...)
|
||||
(contract
|
||||
(combined (at ?type-name (predicate real-predicate))
|
||||
component-contract ...))))))))
|
||||
(with-syntax ((defs
|
||||
(stepper-syntax-property
|
||||
(syntax/loc x defs) 'stepper-skip-completely #t))
|
||||
|
|
@ -173,6 +166,7 @@
|
|||
defs)))))))
|
||||
|
||||
((_ ?type-name
|
||||
?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
rest)
|
||||
|
|
@ -180,6 +174,7 @@
|
|||
#f
|
||||
"Der vierte Operand ist illegal" (syntax rest)))
|
||||
((_ ?type-name
|
||||
?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
rest1 rest2 ... (?field-spec ...))
|
||||
|
|
@ -187,16 +182,17 @@
|
|||
#f
|
||||
"Vor den Selektoren/Mutatoren steht eine Form zuviel" #'rest1))
|
||||
((_ ?type-name
|
||||
?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
rest1 rest2 ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"Zu viele Operanden für define-record-procedures-2" x))
|
||||
"Zu viele Operanden für define-record-procedures*" x))
|
||||
((_ arg1 ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"Zu wenige Operanden für define-record-procedures-2" x))))))
|
||||
"Zu wenige Operanden für define-record-procedures*" x))))))
|
||||
|
||||
(define (access-record-fields rec acc count)
|
||||
(let recur ((i 0))
|
||||
|
|
@ -294,6 +290,7 @@ prints as:
|
|||
(generate-temporaries (syntax (accessor ...)))))
|
||||
(syntax
|
||||
(define-record-procedures* ?type-name
|
||||
dummy-contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
((accessor dummy-mutator) ...))))))
|
||||
|
|
@ -328,34 +325,26 @@ prints as:
|
|||
(define-syntax define-record-procedures-parametric
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ (?type-name ?param ...)
|
||||
((_ ?type-name
|
||||
?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
(accessor ...))
|
||||
|
||||
|
||||
(begin
|
||||
(check-for-id-list! (syntax->list #'(?param ...))
|
||||
"Parameter ist kein Bezeichner")
|
||||
(when (not (= (length (syntax->list #'(?param ...)))
|
||||
(length (syntax->list #'(accessor ...)))))
|
||||
(raise-syntax-error #f
|
||||
(string-append "Anzahlen der Konstruktor-Parameter "
|
||||
"und der Felder sollten übereinstimmen")
|
||||
#'?constructor))
|
||||
(check-for-id!
|
||||
(syntax ?type-name)
|
||||
"Record-Name ist kein Bezeichner")
|
||||
|
||||
(check-for-id!
|
||||
(syntax ?contract-constructor-name)
|
||||
"Vertrags-Konstruktor-Name ist kein Bezeichner")
|
||||
|
||||
(check-for-id!
|
||||
(syntax ?constructor)
|
||||
"Konstruktor ist kein Bezeichner")
|
||||
|
||||
(check-for-id!
|
||||
(syntax ?type-name)
|
||||
"Typ-Name ist kein Bezeichner")
|
||||
|
||||
(for-each (lambda (param)
|
||||
(check-for-id! param
|
||||
"Parameter ist kein Bezeichner"))
|
||||
(syntax->list #'(?param ...)))
|
||||
|
||||
(check-for-id!
|
||||
(syntax ?predicate)
|
||||
"Prädikat ist kein Bezeichner")
|
||||
|
|
@ -367,12 +356,13 @@ prints as:
|
|||
(with-syntax (((dummy-mutator ...)
|
||||
(generate-temporaries (syntax (accessor ...)))))
|
||||
(syntax
|
||||
(define-record-procedures* (?type-name ?param ...)
|
||||
(define-record-procedures* ?type-name ?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
((accessor dummy-mutator) ...))))))
|
||||
|
||||
((_ ?type-name
|
||||
?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
rest)
|
||||
|
|
@ -380,18 +370,21 @@ prints as:
|
|||
#f
|
||||
"Der vierte Operand ist keine Liste von Selektoren" (syntax rest)))
|
||||
((_ ?type-name
|
||||
?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
rest1 rest2 ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"Zu viele Operanden für define-record-procedures-polymorphic" x))
|
||||
"Zu viele Operanden für define-record-procedures-parametric" x))
|
||||
((_ arg1 ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"Zu wenige Operanden für define-record-procedures-polymorphic" x))
|
||||
"Zu wenige Operanden für define-record-procedures-parametric" x))
|
||||
)))
|
||||
|
||||
;; (define-record-procedures-2 :pare kons pare? ((kar set-kar!) kdr))
|
||||
|
||||
(define-syntax define-record-procedures-2
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
|
|
@ -403,7 +396,7 @@ prints as:
|
|||
(begin
|
||||
(check-for-id!
|
||||
(syntax ?type-name)
|
||||
"Typ-Name ist kein Bezeichner")
|
||||
"Record-Name ist kein Bezeichner")
|
||||
|
||||
(check-for-id!
|
||||
(syntax ?constructor)
|
||||
|
|
@ -426,6 +419,7 @@ prints as:
|
|||
(syntax->list (syntax (?field-spec ...))))
|
||||
|
||||
#'(define-record-procedures* ?type-name
|
||||
dummy-contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
(?field-spec ...))))
|
||||
|
|
@ -451,21 +445,21 @@ prints as:
|
|||
(define-syntax define-record-procedures-parametric-2
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ (?type-name ?param ...)
|
||||
((_ ?type-name
|
||||
?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
(?field-spec ...))
|
||||
|
||||
(begin
|
||||
(check-for-id-list! (syntax->list #'(?param ...))
|
||||
"Parameter ist kein Bezeichner")
|
||||
(when (not (= (length (syntax->list #'(?param ...)))
|
||||
(length (syntax->list #'(?field-spec ...)))))
|
||||
(raise-syntax-error #f
|
||||
(string-append "Anzahlen der Konstruktor-Parameter "
|
||||
"und der Felder sollten übereinstimmen")
|
||||
#'?constructor))
|
||||
|
||||
(check-for-id!
|
||||
(syntax ?type-name)
|
||||
"Record-Name ist kein Bezeichner")
|
||||
|
||||
(check-for-id!
|
||||
(syntax ?contract-constructor-name)
|
||||
"Vertrags-Konstruktor-Name ist kein Bezeichner")
|
||||
|
||||
(check-for-id!
|
||||
(syntax ?constructor)
|
||||
"Konstruktor ist kein Bezeichner")
|
||||
|
|
@ -486,11 +480,12 @@ prints as:
|
|||
"Selektor ist kein Bezeichner"))))
|
||||
(syntax->list (syntax (?field-spec ...))))
|
||||
|
||||
#'(define-record-procedures* (?type-name ?param ...)
|
||||
#'(define-record-procedures* ?type-name ?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
(?field-spec ...))))
|
||||
((_ ?type-name
|
||||
?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
rest)
|
||||
|
|
@ -498,15 +493,16 @@ prints as:
|
|||
#f
|
||||
"Der vierte Operand ist illegal" (syntax rest)))
|
||||
((_ ?type-name
|
||||
?contract-constructor-name
|
||||
?constructor
|
||||
?predicate
|
||||
rest1 rest2 ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"Zu viele Operanden für define-record-procedures-2" x))
|
||||
"Zu viele Operanden für define-record-procedures-parametric-2" x))
|
||||
((_ arg1 ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"Zu wenige Operanden für define-record-procedures-2" x)))))
|
||||
"Zu wenige Operanden für define-record-procedures-parametric-2" x)))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ Abstraktion - fortgeschritten} that goes with the German textbook
|
|||
#:literals (define-record-procedures-2 set!)
|
||||
(
|
||||
(define-record-procedures-2 id id id (field-spec ...))
|
||||
(define-record-procedures-parametric-2 (id id ...) id id (field-spec ...))
|
||||
(define-record-procedures-parametric-2 id id id id (field-spec ...))
|
||||
)
|
||||
(
|
||||
[field-spec id (id id)]
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ Abstraktion mit Zuweisungen} to go with the German textbook
|
|||
#:literals (define-record-procedures-2 define-record-procedures-parametric-2 set!)
|
||||
(
|
||||
(define-record-procedures-2 id id id (field-spec ...))
|
||||
(define-record-procedures-parametric-2 (id id ...) id id (field-spec ...))
|
||||
(define-record-procedures-parametric-2 id id id id id (field-spec ...))
|
||||
)
|
||||
(
|
||||
[field-spec id (id id)]
|
||||
|
|
@ -43,7 +43,7 @@ Mutators sein.
|
|||
|
||||
@section{@scheme[define-record-procedures-parametric-2]}
|
||||
|
||||
@defform[(define-record-procedures-parametric-2 (t p1 ...) c p (field-spec1 ...))]{
|
||||
@defform[(define-record-procedures-parametric-2 t cc c p (field-spec1 ...))]{
|
||||
Diese Form ist wie @scheme[define-record-procedures-2], nur parametrisch
|
||||
wie @schemeidfont{define-record-procedures-parametric}.}
|
||||
|
||||
|
|
|
|||
|
|
@ -342,25 +342,26 @@ wurden. In diesen Fällen erzeugt @scheme[check-property] eine Fehlermeldung.
|
|||
|
||||
@section{Parametrische Record-Typ-Definitionen}
|
||||
|
||||
@defform[(define-record-procedures-parametric (t p1 ...) c p (s1 ...))]{
|
||||
@defform[(define-record-procedures-parametric t cc c p (s1 ...))]{
|
||||
|
||||
Die @scheme[define-record-procedures-parametric] ist wie
|
||||
@scheme[define-record-procedures] mit dem Unterschied, daß @scheme[t]
|
||||
an einen parametrischen Vertrag gebunden wird: Es muß genauso viele
|
||||
Parameter @scheme[p1] geben wie Selektoren @scheme[s1]; für diese
|
||||
Parameter werden die Verträge für die Felder substituiert.
|
||||
@scheme[define-record-procedures]. Zusäzlich wird der Bezeichner
|
||||
@scheme[cc] an einen Vertragskonstruktor gebunden: Dieser akzeptiert
|
||||
für jedes Feld einen Feld-Vertrag und liefert einen Vertrag, den nur
|
||||
Records des Record-Typs @scheme[t] erfüllen, bei dem die Feldinhalte
|
||||
die Feld-Verträge erfüllen.
|
||||
|
||||
Beispiel:
|
||||
|
||||
@schemeblock[
|
||||
(define-record-procedures-parametric (pare a b)
|
||||
(define-record-procedures-parametric pare pare-of
|
||||
make-pare pare?
|
||||
(pare-one pare-two))
|
||||
]
|
||||
|
||||
Dann ist @scheme[(pare integer string)] der Vertrag für
|
||||
@scheme[pare]-Records, bei dem die Felder die Verträge
|
||||
@scheme[integer] respektive @scheme[string] erfüllen müssen.
|
||||
Dann ist @scheme[(pare-of integer string)] der Vertrag für
|
||||
@scheme[pare]-Records, bei dem die Feldinhalte die Verträge
|
||||
@scheme[integer] bzw. @scheme[string] erfüllen müssen.
|
||||
}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user