diff --git a/collects/lang/doc.txt b/collects/lang/doc.txt index 1aa619a2a5..701182a03c 100644 --- a/collects/lang/doc.txt +++ b/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. diff --git a/collects/lang/htdp-beginner.ss b/collects/lang/htdp-beginner.ss index a19540c1e5..bc79ebf245 100644 --- a/collects/lang/htdp-beginner.ss +++ b/collects/lang/htdp-beginner.ss @@ -11,7 +11,7 @@ ;; Implements the forms: (require "private/teach.ss" "private/contract-forms.ss") - + ;; syntax: (provide (rename beginner-define define) (rename beginner-define-struct define-struct) @@ -29,7 +29,13 @@ ; (rename beginner-define-data define-data) #%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,20 +58,23 @@ [else #'("primitive operator" "applied to arguments")])]) - #'(define-syntax (new-name stx) - (syntax-case stx () - [(id . args) - (syntax/loc stx (beginner-app orig-name . args))] - [_else - (raise-syntax-error - #f - (format - "this ~a must be ~a; expected an open parenthesis before the ~a name" - what - something - what) - stx)])))))])) - + #'(define-syntax new-name + (make-first-order + (lambda (stx) + (syntax-case stx () + [(id . args) + (syntax/loc stx (beginner-app orig-name . args))] + [_else + (raise-syntax-error + #f + (format + "this ~a must be ~a; expected an open parenthesis before the ~a name" + what + something + what) + stx)])) + #'orig-name)))))])) + ;; procedures: (provide-and-document/wrap procedures diff --git a/collects/lang/prim.ss b/collects/lang/prim.ss index 5d32aa503a..e510e65296 100644 --- a/collects/lang/prim.ss +++ b/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,29 +22,33 @@ (with-syntax ([impl #'(let ([name (lambda argv (apply implementation argv))]) name)]) - #'(define-syntax (name stx) - (with-syntax ([tagged-impl (syntax-property - (syntax-property (quote-syntax impl) 'stepper-skip-completely #t) - 'stepper-prim-name - (quote-syntax name))]) - (syntax-case stx () - [(__ . ___) - ;; 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 . ___))] - [__ - ;; HACK: see above - (not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app))) - (syntax/loc stx tagged-impl)] - [(id . args) - (syntax/loc stx (#%app tagged-impl . args))] - [_else - (raise-syntax-error - #f - (string-append - "this primitive operator must be applied to arguments; " - "expected an open parenthesis before the operator 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 + (quote-syntax name))]) + (syntax-case stx () + [(__ . ___) + ;; 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 . ___))] + [__ + ;; HACK: see above + (not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app))) + (syntax/loc stx tagged-impl)] + [(id . args) + (syntax/loc stx (#%app tagged-impl . args))] + [_else + (raise-syntax-error + #f + (string-append + "this primitive operator must be applied to arguments; " + "expected an open parenthesis before the operator name") + stx)]))) + ((syntax-local-certifier) + #'impl))))])) (define-syntax (define-higher-order-primitive stx) (define (is-proc-arg? arg) @@ -83,41 +88,45 @@ (implementation new-arg ...))]) name)]) (syntax/loc stx - (define-syntax (name s) - (with-syntax ([tagged-impl (syntax-property - (syntax-property (quote-syntax impl) 'stepper-skip-completely #t) - 'stepper-prim-name - (quote-syntax name))]) - (syntax-case s () - [(__ . ___) - ;; HACK: see above - (not (module-identifier=? #'beginner-app (datum->syntax-object s '#%app))) - (syntax/loc s (tagged-impl . ___))] - [__ - ;; HACK: see above - (not (module-identifier=? #'beginner-app (datum->syntax-object s '#%app))) - (syntax/loc s tagged-impl)] - [(__ new-arg ...) - (begin - checks ... - ;; s is a well-formed use of the primitive; - ;; generate the primitive implementation - (syntax/loc s (tagged-impl wrapped-arg ...)) - )] - [(__ . rest) - (raise-syntax-error - #f - (format - "primitive operator requires ~a arguments" - num-arguments) - s)] - [_else - (raise-syntax-error - #f - (string-append - "this primitive operator must be applied to arguments; " - "expected an open parenthesis before the operator 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 + (quote-syntax name))]) + (syntax-case s () + [(__ . ___) + ;; HACK: see above + (not (module-identifier=? #'beginner-app (datum->syntax-object s '#%app))) + (syntax/loc s (tagged-impl . ___))] + [__ + ;; HACK: see above + (not (module-identifier=? #'beginner-app (datum->syntax-object s '#%app))) + (syntax/loc s tagged-impl)] + [(__ new-arg ...) + (begin + checks ... + ;; s is a well-formed use of the primitive; + ;; generate the primitive implementation + (syntax/loc s (tagged-impl wrapped-arg ...)) + )] + [(__ . rest) + (raise-syntax-error + #f + (format + "primitive operator requires ~a arguments" + num-arguments) + s)] + [_else + (raise-syntax-error + #f + (string-append + "this primitive operator must be applied to arguments; " + "expected an open parenthesis before the operator name") + s)]))) + ((syntax-local-certifier) + #'impl))))))))])) (define-syntax (fo->ho stx) (syntax-case stx () diff --git a/collects/lang/private/firstorder.ss b/collects/lang/private/firstorder.ss index 64aaa4e19f..6181bb0929 100644 --- a/collects/lang/private/firstorder.ss +++ b/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))) - (syntax-local-introduce - (fo-proc-id (set!-transformer-procedure v))) + (if (or (fo? v) + (and (set!-transformer? v) + (fo? (set!-transformer-procedure v)))) + (syntax-local-introduce + (fo-proc-id (if (fo? v) v (set!-transformer-procedure v)))) id))))