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

svn: r4666
This commit is contained in:
Matthew Flatt 2006-10-21 02:28:30 +00:00
parent c4cc339f69
commit 6b13db5211
4 changed files with 99 additions and 80 deletions

View File

@ -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.

View File

@ -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

View File

@ -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 ()

View File

@ -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))))