From 8971cb5981fcf1b521d19dff9ed2ccf28aab62e8 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 28 Sep 2012 15:07:49 -0500
Subject: [PATCH] adjust define-primitive so that it cooperates with
 struct-info.

Specifically, if there is a third argument to define-primitive, then
it uses the prop:struct-info setup, using that third argument
as the struct-info (in the list format).
---
 collects/lang/prim.rkt               | 76 ++++++++++++++++------------
 collects/lang/private/firstorder.rkt | 37 +++++++++-----
 2 files changed, 68 insertions(+), 45 deletions(-)

diff --git a/collects/lang/prim.rkt b/collects/lang/prim.rkt
index 1d37678d84..977300369d 100644
--- a/collects/lang/prim.rkt
+++ b/collects/lang/prim.rkt
@@ -18,40 +18,50 @@
            first-order->higher-order)
 
   (define-syntax (define-primitive stx)
+    (define (go name implementation struct-info)
+      (with-syntax ([name name][implementation implementation])
+        (with-syntax ([impl #'(let ([name (lambda argv
+                                            (apply implementation argv))])
+                                name)])
+          #`(begin
+              ;; Make sure that `implementation' is bound:
+              (define-values () (begin (lambda () implementation) (values)))
+              ;; Bind `name':
+              (define-syntax name 
+                (#,(if struct-info
+                       #'fo:make-first-order+struct
+                       #'fo:make-first-order)
+                 (lambda (stx)
+                   (with-syntax ([tagged-impl (stepper-syntax-property
+                                               (stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
+                                               'stepper-prim-name
+                                               (quote-syntax name))])
+                     (syntax-case stx ()
+                       [(_ . body)
+                        ;; HACK: we disable all checks if #%app is not beginner-app
+                        (not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
+                        (syntax/loc stx (tagged-impl . body))]
+                       [_
+                        ;; HACK: see above
+                        (not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
+                        (syntax/loc stx tagged-impl)]
+                       [(id . args)
+                        (syntax/loc stx (#%plain-app tagged-impl . args))]
+                       [_
+                        (raise-syntax-error
+                         #f
+                         "expected a function call, but there is no open parenthesis before this function"
+                         stx)])))
+                 ((syntax-local-certifier #t)
+                  #'impl)
+                 #,@(if struct-info
+                        (list struct-info)
+                        '())))))))
     (syntax-case stx ()
-      [(_ name implementation)
-       (with-syntax ([impl #'(let ([name (lambda argv
-                                           (apply implementation argv))])
-                               name)])
-	 #'(begin
-             ;; Make sure that `implementation' is bound:
-             (define-values () (begin (lambda () implementation) (values)))
-             ;; Bind `name':
-             (define-syntax name 
-               (fo:make-first-order
-                (lambda (stx)
-                  (with-syntax ([tagged-impl (stepper-syntax-property
-                                              (stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
-                                              'stepper-prim-name
-                                              (quote-syntax name))])
-                    (syntax-case stx ()
-                      [(_ . body)
-                       ;; HACK: we disable all checks if #%app is not beginner-app
-                       (not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
-                       (syntax/loc stx (tagged-impl . body))]
-                      [_
-                       ;; HACK: see above
-                       (not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
-                       (syntax/loc stx tagged-impl)]
-                      [(id . args)
-                       (syntax/loc stx (#%plain-app tagged-impl . args))]
-                      [_
-                       (raise-syntax-error
-                        #f
-                        "expected a function call, but there is no open parenthesis before this function"
-                        stx)])))
-                ((syntax-local-certifier #t)
-                 #'impl)))))]))
+      [(_ name implementation) (go #'name #'implementation #f)]
+      [(_ name implementation inf)
+       (go #'name #'implementation #'inf)]))
+
 
   (define-syntax (define-higher-order-primitive stx)
     (define (is-proc-arg? arg)
diff --git a/collects/lang/private/firstorder.rkt b/collects/lang/private/firstorder.rkt
index e8eb8de666..96f3ff0682 100644
--- a/collects/lang/private/firstorder.rkt
+++ b/collects/lang/private/firstorder.rkt
@@ -1,23 +1,36 @@
 (module firstorder mzscheme
-
+  (require racket/struct-info)
   (provide make-first-order
-	   first-order->higher-order)
-
+           make-first-order+struct
+           first-order->higher-order
+           fo+struct?
+           fo?)
+  
+  (define (fo-either? x) (or (fo? x) (fo+struct? x)))
+  (define (fo-either-proc-id x)
+    (if (fo? x)
+        (fo-proc-id x)
+        (fo+struct-proc-id x)))
+  
   (define-values (struct:fo make-first-order fo? fo-get fo-set!)
-    (make-struct-type 'procedure #f 2 0 #f null (current-inspector) 0))  
-
+    (make-struct-type 'procedure #f 2 0 #f null (current-inspector) 0))
+  
+  (define-values (struct:fo+struct make-first-order+struct fo+struct? fo+struct-get fo+struct-set!)
+    (let ()
+      (define props (list (cons prop:struct-info (λ (s) (fo+struct-get s 2)))))
+      (make-struct-type 'procedure #f 3 0 #f props (current-inspector) 0)))
+  
   (define fo-proc-id (make-struct-field-accessor fo-get 1))
-
+  (define fo+struct-proc-id (make-struct-field-accessor fo+struct-get 1))
+  
   (define (first-order->higher-order id)
     (let ([v (syntax-local-value id (lambda () #f))])
-      (if (or (fo? v)
+      (if (or (fo-either? v)
               (and (set!-transformer? v)
-                   (fo? (set!-transformer-procedure v))))
+                   (fo-either? (set!-transformer-procedure v))))
           (syntax-property
            (syntax-local-introduce 
-            (fo-proc-id (if (fo? v) v (set!-transformer-procedure v))))
+            (fo-either-proc-id (if (fo-either? v) v (set!-transformer-procedure v))))
            'disappeared-use
            (syntax-local-introduce id))
-	  id))))
-
-
+          id))))