suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Massage syntax of `define-record-procedures-parametric'.

Browse Source 
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 2009-09-17 12:33:36 +00:00
parent 34d365d3a8
commit 698199d68c
4 changed files with 72 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
collects/deinprogramm/define-record-procedures.scm
View File

@ -1,5 +1,3 @@
;; (define-record-procedures-2 :pare kons pare? ((kar set-kar!) kdr))
(define-syntax define-record-procedures* (define-syntax define-record-procedures*
(let () (let ()
@ -28,18 +26,14 @@
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ ?type-spec ((_ ?type-name
?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
(?field-spec ...)) (?field-spec ...))
(with-syntax (with-syntax
((?type-name (syntax-case #'?type-spec () (((accessor ...)
((?id ?param ...)
#'?id)
(?id
#'?id)))
((accessor ...)
(map (lambda (field-spec) (map (lambda (field-spec)
(syntax-case field-spec () (syntax-case field-spec ()
((accessor mutator) (syntax accessor)) ((accessor mutator) (syntax accessor))
@ -142,23 +136,22 @@
accessor-proc ... accessor-proc ...
mutator-proc ...)))) mutator-proc ...))))
(contract (contract
(syntax-case #'?type-spec () (with-syntax (((?param ...) (generate-temporaries #'(?field-spec ...))))
((_ ?param ...) (with-syntax (((component-contract ...)
(with-syntax (((component-contract ...) (map (lambda (accessor param)
(map (lambda (accessor param) (with-syntax ((?accessor accessor)
(with-syntax ((?accessor accessor) (?param param))
(?param param)) #'(at ?param (property ?accessor ?param))))
#'(at ?param (property ?accessor ?param)))) (syntax->list #'(our-accessor ...))
(syntax->list #'(our-accessor ...)) (syntax->list #'(?param ...)))))
(syntax->list #'(?param ...))))) #'(begin
#'(define ?type-spec ;; we use real-predicate to avoid infinite recursion if a contract
(contract ;; for ?type-name using ?predicate is inadvertently defined
(combined (at ?type-name (predicate real-predicate)) (define ?type-name (contract (predicate real-predicate)))
component-contract ...))))) (define (?contract-constructor-name ?param ...)
(_ (contract
;; we use real-predicate to avoid infinite recursion if a contract (combined (at ?type-name (predicate real-predicate))
;; for ?type-name using ?predicate is inadvertently defined component-contract ...))))))))
#'(define ?type-name (contract (predicate real-predicate)))))))
(with-syntax ((defs (with-syntax ((defs
(stepper-syntax-property (stepper-syntax-property
(syntax/loc x defs) 'stepper-skip-completely #t)) (syntax/loc x defs) 'stepper-skip-completely #t))
@ -173,6 +166,7 @@
defs))))))) defs)))))))
((_ ?type-name ((_ ?type-name
?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
rest) rest)
@ -180,6 +174,7 @@
#f #f
"Der vierte Operand ist illegal" (syntax rest))) "Der vierte Operand ist illegal" (syntax rest)))
((_ ?type-name ((_ ?type-name
?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
rest1 rest2 ... (?field-spec ...)) rest1 rest2 ... (?field-spec ...))
@ -187,16 +182,17 @@
#f #f
"Vor den Selektoren/Mutatoren steht eine Form zuviel" #'rest1)) "Vor den Selektoren/Mutatoren steht eine Form zuviel" #'rest1))
((_ ?type-name ((_ ?type-name
?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
rest1 rest2 ...) rest1 rest2 ...)
(raise-syntax-error (raise-syntax-error
#f #f
"Zu viele Operanden für define-record-procedures-2" x)) "Zu viele Operanden für define-record-procedures*" x))
((_ arg1 ...) ((_ arg1 ...)
(raise-syntax-error (raise-syntax-error
#f #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) (define (access-record-fields rec acc count)
(let recur ((i 0)) (let recur ((i 0))
@ -294,6 +290,7 @@ prints as:
(generate-temporaries (syntax (accessor ...))))) (generate-temporaries (syntax (accessor ...)))))
(syntax (syntax
(define-record-procedures* ?type-name (define-record-procedures* ?type-name
dummy-contract-constructor-name
?constructor ?constructor
?predicate ?predicate
((accessor dummy-mutator) ...)))))) ((accessor dummy-mutator) ...))))))
@ -328,34 +325,26 @@ prints as:
(define-syntax define-record-procedures-parametric (define-syntax define-record-procedures-parametric
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ (?type-name ?param ...) ((_ ?type-name
?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
(accessor ...)) (accessor ...))
(begin (begin
(check-for-id-list! (syntax->list #'(?param ...)) (check-for-id!
"Parameter ist kein Bezeichner") (syntax ?type-name)
(when (not (= (length (syntax->list #'(?param ...))) "Record-Name ist kein Bezeichner")
(length (syntax->list #'(accessor ...)))))
(raise-syntax-error #f (check-for-id!
(string-append "Anzahlen der Konstruktor-Parameter " (syntax ?contract-constructor-name)
"und der Felder sollten übereinstimmen") "Vertrags-Konstruktor-Name ist kein Bezeichner")
#'?constructor))
(check-for-id! (check-for-id!
(syntax ?constructor) (syntax ?constructor)
"Konstruktor ist kein Bezeichner") "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! (check-for-id!
(syntax ?predicate) (syntax ?predicate)
"Prädikat ist kein Bezeichner") "Prädikat ist kein Bezeichner")
@ -367,12 +356,13 @@ prints as:
(with-syntax (((dummy-mutator ...) (with-syntax (((dummy-mutator ...)
(generate-temporaries (syntax (accessor ...))))) (generate-temporaries (syntax (accessor ...)))))
(syntax (syntax
(define-record-procedures* (?type-name ?param ...) (define-record-procedures* ?type-name ?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
((accessor dummy-mutator) ...)))))) ((accessor dummy-mutator) ...))))))
((_ ?type-name ((_ ?type-name
?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
rest) rest)
@ -380,18 +370,21 @@ prints as:
#f #f
"Der vierte Operand ist keine Liste von Selektoren" (syntax rest))) "Der vierte Operand ist keine Liste von Selektoren" (syntax rest)))
((_ ?type-name ((_ ?type-name
?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
rest1 rest2 ...) rest1 rest2 ...)
(raise-syntax-error (raise-syntax-error
#f #f
"Zu viele Operanden für define-record-procedures-polymorphic" x)) "Zu viele Operanden für define-record-procedures-parametric" x))
((_ arg1 ...) ((_ arg1 ...)
(raise-syntax-error (raise-syntax-error
#f #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 (define-syntax define-record-procedures-2
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
@ -403,7 +396,7 @@ prints as:
(begin (begin
(check-for-id! (check-for-id!
(syntax ?type-name) (syntax ?type-name)
"Typ-Name ist kein Bezeichner") "Record-Name ist kein Bezeichner")
(check-for-id! (check-for-id!
(syntax ?constructor) (syntax ?constructor)
@ -426,6 +419,7 @@ prints as:
(syntax->list (syntax (?field-spec ...)))) (syntax->list (syntax (?field-spec ...))))
#'(define-record-procedures* ?type-name #'(define-record-procedures* ?type-name
dummy-contract-constructor-name
?constructor ?constructor
?predicate ?predicate
(?field-spec ...)))) (?field-spec ...))))
@ -451,21 +445,21 @@ prints as:
(define-syntax define-record-procedures-parametric-2 (define-syntax define-record-procedures-parametric-2
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ (?type-name ?param ...) ((_ ?type-name
?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
(?field-spec ...)) (?field-spec ...))
(begin (begin
(check-for-id-list! (syntax->list #'(?param ...)) (check-for-id!
"Parameter ist kein Bezeichner") (syntax ?type-name)
(when (not (= (length (syntax->list #'(?param ...))) "Record-Name ist kein Bezeichner")
(length (syntax->list #'(?field-spec ...)))))
(raise-syntax-error #f (check-for-id!
(string-append "Anzahlen der Konstruktor-Parameter " (syntax ?contract-constructor-name)
"und der Felder sollten übereinstimmen") "Vertrags-Konstruktor-Name ist kein Bezeichner")
#'?constructor))
(check-for-id! (check-for-id!
(syntax ?constructor) (syntax ?constructor)
"Konstruktor ist kein Bezeichner") "Konstruktor ist kein Bezeichner")
@ -486,11 +480,12 @@ prints as:
"Selektor ist kein Bezeichner")))) "Selektor ist kein Bezeichner"))))
(syntax->list (syntax (?field-spec ...)))) (syntax->list (syntax (?field-spec ...))))
#'(define-record-procedures* (?type-name ?param ...) #'(define-record-procedures* ?type-name ?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
(?field-spec ...)))) (?field-spec ...))))
((_ ?type-name ((_ ?type-name
?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
rest) rest)
@ -498,15 +493,16 @@ prints as:
#f #f
"Der vierte Operand ist illegal" (syntax rest))) "Der vierte Operand ist illegal" (syntax rest)))
((_ ?type-name ((_ ?type-name
?contract-constructor-name
?constructor ?constructor
?predicate ?predicate
rest1 rest2 ...) rest1 rest2 ...)
(raise-syntax-error (raise-syntax-error
#f #f
"Zu viele Operanden für define-record-procedures-2" x)) "Zu viele Operanden für define-record-procedures-parametric-2" x))
((_ arg1 ...) ((_ arg1 ...)
(raise-syntax-error (raise-syntax-error
#f #f
"Zu wenige Operanden für define-record-procedures-2" x))))) "Zu wenige Operanden für define-record-procedures-parametric-2" x)))))

2
collects/deinprogramm/scribblings/DMdA-advanced.scrbl
View File

@ -16,7 +16,7 @@ Abstraktion - fortgeschritten} that goes with the German textbook
#:literals (define-record-procedures-2 set!) #:literals (define-record-procedures-2 set!)
( (
(define-record-procedures-2 id id id (field-spec ...)) (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)] [field-spec id (id id)]

4
collects/deinprogramm/scribblings/DMdA-assignments.scrbl
View File

@ -16,7 +16,7 @@ Abstraktion mit Zuweisungen} to go with the German textbook
#:literals (define-record-procedures-2 define-record-procedures-parametric-2 set!) #:literals (define-record-procedures-2 define-record-procedures-parametric-2 set!)
( (
(define-record-procedures-2 id id id (field-spec ...)) (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)] [field-spec id (id id)]
@ -43,7 +43,7 @@ Mutators sein.
@section{@scheme[define-record-procedures-parametric-2]} @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 Diese Form ist wie @scheme[define-record-procedures-2], nur parametrisch
wie @schemeidfont{define-record-procedures-parametric}.} wie @schemeidfont{define-record-procedures-parametric}.}

19
collects/deinprogramm/scribblings/DMdA-beginner.scrbl
View File

@ -342,25 +342,26 @@ wurden. In diesen Fällen erzeugt @scheme[check-property] eine Fehlermeldung.
@section{Parametrische Record-Typ-Definitionen} @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 Die @scheme[define-record-procedures-parametric] ist wie
@scheme[define-record-procedures] mit dem Unterschied, daß @scheme[t] @scheme[define-record-procedures]. Zusäzlich wird der Bezeichner
an einen parametrischen Vertrag gebunden wird: Es muß genauso viele @scheme[cc] an einen Vertragskonstruktor gebunden: Dieser akzeptiert
Parameter @scheme[p1] geben wie Selektoren @scheme[s1]; für diese für jedes Feld einen Feld-Vertrag und liefert einen Vertrag, den nur
Parameter werden die Verträge für die Felder substituiert. Records des Record-Typs @scheme[t] erfüllen, bei dem die Feldinhalte
die Feld-Verträge erfüllen.
Beispiel: Beispiel:
@schemeblock[ @schemeblock[
(define-record-procedures-parametric (pare a b) (define-record-procedures-parametric pare pare-of
make-pare pare? make-pare pare?
(pare-one pare-two)) (pare-one pare-two))
] ]
Dann ist @scheme[(pare integer string)] der Vertrag für Dann ist @scheme[(pare-of integer string)] der Vertrag für
@scheme[pare]-Records, bei dem die Felder die Verträge @scheme[pare]-Records, bei dem die Feldinhalte die Verträge
@scheme[integer] respektive @scheme[string] erfüllen müssen. @scheme[integer] bzw. @scheme[string] erfüllen müssen.
} }
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------