From 698199d68c92eac19b3de2b4efa296e1c3f10b0a Mon Sep 17 00:00:00 2001
From: Mike Sperber <sperber@deinprogramm.de>
Date: Thu, 17 Sep 2009 12:33:36 +0000
Subject: [PATCH] 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
---
 .../deinprogramm/define-record-procedures.scm | 122 +++++++++---------
 .../scribblings/DMdA-advanced.scrbl           |   2 +-
 .../scribblings/DMdA-assignments.scrbl        |   4 +-
 .../scribblings/DMdA-beginner.scrbl           |  19 +--
 4 files changed, 72 insertions(+), 75 deletions(-)

diff --git a/collects/deinprogramm/define-record-procedures.scm b/collects/deinprogramm/define-record-procedures.scm
index ffd1a9d150..a92f74e9fe 100644
--- a/collects/deinprogramm/define-record-procedures.scm
+++ b/collects/deinprogramm/define-record-procedures.scm
@@ -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)))))
 
 
diff --git a/collects/deinprogramm/scribblings/DMdA-advanced.scrbl b/collects/deinprogramm/scribblings/DMdA-advanced.scrbl
index 5ebebc89a5..ac1946ce77 100644
--- a/collects/deinprogramm/scribblings/DMdA-advanced.scrbl
+++ b/collects/deinprogramm/scribblings/DMdA-advanced.scrbl
@@ -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)]
diff --git a/collects/deinprogramm/scribblings/DMdA-assignments.scrbl b/collects/deinprogramm/scribblings/DMdA-assignments.scrbl
index 9c0a54a211..621437d299 100644
--- a/collects/deinprogramm/scribblings/DMdA-assignments.scrbl
+++ b/collects/deinprogramm/scribblings/DMdA-assignments.scrbl
@@ -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}.}
 
diff --git a/collects/deinprogramm/scribblings/DMdA-beginner.scrbl b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl
index 5f3dd4308c..e54ec4b3c5 100644
--- a/collects/deinprogramm/scribblings/DMdA-beginner.scrbl
+++ b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl
@@ -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.
 }
 
 @; ----------------------------------------------------------------------