suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

first-order->higher-order from lang/prim

Browse Source 
svn: r12369
This commit is contained in:
Matthew Flatt 2008-11-10 03:21:51 +00:00
parent fbd683abb0
commit a63a20bd83
2 changed files with 18 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/lang/htdp-lib.scrbl
View File

@ -161,3 +161,13 @@ they can be syntactically restricted to application positions.
@scheme[id] is exported as the primitive operator named @scheme[id] is exported as the primitive operator named
@scheme[id]. An alternative to @scheme[define-higher-order-primitive].} @scheme[id]. An alternative to @scheme[define-higher-order-primitive].}
@defform[(first-order->higher-order expr)]{
If @scheme[expr] is an identifier for a first-order function (either a
primitive or a function defined within Beginner Student), produces the
function as a value; otherwise, the form is equivalent to
@scheme[expr].
This form is mainly useful for implementing syntactic forms that, like
the application of a higher-order primitive, allow first-order bindings
to be used in an expression position.}

15
collects/lang/prim.ss
View File

@ -8,14 +8,15 @@
(require lang/error (require lang/error
(rename lang/htdp-beginner beginner-app #%app)) (rename lang/htdp-beginner beginner-app #%app))
(require-for-syntax "private/firstorder.ss" (require-for-syntax (prefix fo: "private/firstorder.ss")
stepper/private/shared) stepper/private/shared)
(provide define-primitive (provide define-primitive
define-higher-order-primitive define-higher-order-primitive
provide-primitive provide-primitive
provide-higher-order-primitive provide-higher-order-primitive
provide-primitives) provide-primitives
first-order->higher-order)
(define-syntax (define-primitive stx) (define-syntax (define-primitive stx)
(syntax-case stx () (syntax-case stx ()
@ -24,7 +25,7 @@
(apply implementation argv))]) (apply implementation argv))])
name)]) name)])
#'(define-syntax name #'(define-syntax name
(make-first-order (fo:make-first-order
(lambda (stx) (lambda (stx)
(with-syntax ([tagged-impl (stepper-syntax-property (with-syntax ([tagged-impl (stepper-syntax-property
(stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t) (stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
@ -82,7 +83,7 @@
(map (lambda (arg new-arg) (map (lambda (arg new-arg)
(cond (cond
[(not (is-proc-arg? arg)) new-arg] [(not (is-proc-arg? arg)) new-arg]
[else #`(fo->ho #,new-arg)])) [else #`(first-order->higher-order #,new-arg)]))
args new-args)] args new-args)]
[num-arguments (length args)]) [num-arguments (length args)])
(with-syntax ([impl #'(let ([name (lambda (new-arg ...) (with-syntax ([impl #'(let ([name (lambda (new-arg ...)
@ -90,7 +91,7 @@
name)]) name)])
(syntax/loc stx (syntax/loc stx
(define-syntax name (define-syntax name
(make-first-order (fo:make-first-order
(lambda (s) (lambda (s)
(with-syntax ([tagged-impl (stepper-syntax-property (with-syntax ([tagged-impl (stepper-syntax-property
(stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t) (stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
@ -129,9 +130,9 @@
((syntax-local-certifier #t) ((syntax-local-certifier #t)
#'impl))))))))])) #'impl))))))))]))
(define-syntax (fo->ho stx) (define-syntax (first-order->higher-order stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) (first-order->higher-order #'id)])) [(_ id) (fo:first-order->higher-order #'id)]))
(define-syntax (provide-primitive stx) (define-syntax (provide-primitive stx)
(syntax-case stx () (syntax-case stx ()