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
parent
c4cc339f69
commit
6b13db5211
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user