wrap primitives and beginner-specialized primitives as first order, so that higher-order primitives can recognize them

svn: r4666

collects/lang/doc.txt

@@ -46,7 +46,7 @@ built-in procedures) are distinguished from other types of
 expressions, so that they can be syntactically restricted to
 application positions.
 
-> (define-higher-order-procedure id proc-id (arg ...)) - defines `id'
+> (define-higher-order-primitive id proc-id (arg ...)) - defines `id'
   to be a primitive operator whose implementation is
   `proc-id'. Normally, `id' is exported from the teachpack and
   `proc-id' is not.

collects/lang/htdp-beginner.ss

@@ -30,6 +30,12 @@
 	   #%datum
 	   empty true false)
 
+  (require-for-syntax "private/firstorder.ss")
+    
+  ;; This is essentially a specialized version of `define-primitive'
+  ;;  that refines the error messages for built-in things, which
+  ;;  we might like to call "contructor" or "predicate" instead of
+  ;;  just "primitive".
   (define-syntax (in-rator-position-only stx)
     (syntax-case stx ()
       [(_ new-name orig-name)
@@ -52,7 +58,9 @@
 			      [else
 			       #'("primitive operator"
 				  "applied to arguments")])])
-	       #'(define-syntax (new-name stx)
+	       #'(define-syntax new-name 
+                   (make-first-order
+                    (lambda (stx)
                       (syntax-case stx ()
                         [(id . args)
                          (syntax/loc stx (beginner-app orig-name . args))]
@@ -64,7 +72,8 @@
                            what
                            something
                            what)
-		       stx)])))))]))
+                          stx)]))
+                    #'orig-name)))))]))
       
   ;; procedures:
   (provide-and-document/wrap

collects/lang/prim.ss

@@ -7,7 +7,8 @@
 (module prim mzscheme
   (require (lib "error.ss" "lang")
 	   (rename (lib "htdp-beginner.ss" "lang") beginner-app #%app))
-  (require-for-syntax "private/firstorder.ss")
+  (require-for-syntax "private/firstorder.ss"
+                      "private/primwrap.ss")
   
   (provide define-primitive
 	   define-higher-order-primitive
@@ -21,7 +22,9 @@
        (with-syntax ([impl #'(let ([name (lambda argv
                                            (apply implementation argv))])
                                name)])
-	 #'(define-syntax (name stx)
+	 #'(define-syntax name 
+             (make-first-order
+              (lambda (stx)
                 (with-syntax ([tagged-impl (syntax-property
                                             (syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
                                             'stepper-prim-name
@@ -43,7 +46,9 @@
                       (string-append
                        "this primitive operator must be applied to arguments; "
                        "expected an open parenthesis before the operator name")
-		 stx)]))))]))
+                      stx)])))
+              ((syntax-local-certifier)
+               #'impl))))]))
 
   (define-syntax (define-higher-order-primitive stx)
     (define (is-proc-arg? arg)
@@ -83,7 +88,9 @@
                                                  (implementation new-arg ...))])
                                      name)])
 	       (syntax/loc stx
-		   (define-syntax (name s)
+		   (define-syntax name
+                     (make-first-order
+                      (lambda (s)
                         (with-syntax ([tagged-impl (syntax-property
                                                     (syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
                                                     'stepper-prim-name
@@ -117,7 +124,9 @@
                               (string-append
                                "this primitive operator must be applied to arguments; "
                                "expected an open parenthesis before the operator name")
-			 s)]))))))))]))
+                              s)])))
+                      ((syntax-local-certifier)
+                       #'impl))))))))]))
 
   (define-syntax (fo->ho stx)
     (syntax-case stx ()

collects/lang/private/firstorder.ss

@@ -10,10 +10,11 @@
 
   (define (first-order->higher-order id)
     (let ([v (syntax-local-value id (lambda () #f))])
-      (if (and (set!-transformer? v)
-	       (fo? (set!-transformer-procedure v)))
+      (if (or (fo? v)
+              (and (set!-transformer? v)
+                   (fo? (set!-transformer-procedure v))))
           (syntax-local-introduce 
-	   (fo-proc-id (set!-transformer-procedure v)))
+	   (fo-proc-id (if (fo? v) v (set!-transformer-procedure v))))
 	  id))))