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

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

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/lang/doc.txt
View File

@ -46,7 +46,7 @@ built-in procedures) are distinguished from other types of
expressions, so that they can be syntactically restricted to expressions, so that they can be syntactically restricted to
application positions. 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 to be a primitive operator whose implementation is
`proc-id'. Normally, `id' is exported from the teachpack and `proc-id'. Normally, `id' is exported from the teachpack and
`proc-id' is not. `proc-id' is not.

35
collects/lang/htdp-beginner.ss
View File

@ -30,6 +30,12 @@
#%datum #%datum
empty true false) 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) (define-syntax (in-rator-position-only stx)
(syntax-case stx () (syntax-case stx ()
[(_ new-name orig-name) [(_ new-name orig-name)
@ -52,19 +58,22 @@
[else [else
#'("primitive operator" #'("primitive operator"
"applied to arguments")])]) "applied to arguments")])])
#'(define-syntax (new-name stx) #'(define-syntax new-name
(syntax-case stx () (make-first-order
[(id . args) (lambda (stx)
(syntax/loc stx (beginner-app orig-name . args))] (syntax-case stx ()
[_else [(id . args)
(raise-syntax-error (syntax/loc stx (beginner-app orig-name . args))]
#f [_else
(format (raise-syntax-error
"this ~a must be ~a; expected an open parenthesis before the ~a name" #f
what (format
something "this ~a must be ~a; expected an open parenthesis before the ~a name"
what) what
stx)])))))])) something
what)
stx)]))
#'orig-name)))))]))
;; procedures: ;; procedures:
(provide-and-document/wrap (provide-and-document/wrap

127
collects/lang/prim.ss
View File

@ -7,7 +7,8 @@
(module prim mzscheme (module prim mzscheme
(require (lib "error.ss" "lang") (require (lib "error.ss" "lang")
(rename (lib "htdp-beginner.ss" "lang") beginner-app #%app)) (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 (provide define-primitive
define-higher-order-primitive define-higher-order-primitive
@ -21,29 +22,33 @@
(with-syntax ([impl #'(let ([name (lambda argv (with-syntax ([impl #'(let ([name (lambda argv
(apply implementation argv))]) (apply implementation argv))])
name)]) name)])
#'(define-syntax (name stx) #'(define-syntax name
(with-syntax ([tagged-impl (syntax-property (make-first-order
(syntax-property (quote-syntax impl) 'stepper-skip-completely #t) (lambda (stx)
'stepper-prim-name (with-syntax ([tagged-impl (syntax-property
(quote-syntax name))]) (syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
(syntax-case stx () 'stepper-prim-name
[(__ . ___) (quote-syntax name))])
;; HACK: we disable all checks if #%app is not beginner-app (syntax-case stx ()
(not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app))) [(__ . ___)
(syntax/loc stx (tagged-impl . ___))] ;; HACK: we disable all checks if #%app is not beginner-app
[__ (not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
;; HACK: see above (syntax/loc stx (tagged-impl . ___))]
(not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app))) [__
(syntax/loc stx tagged-impl)] ;; HACK: see above
[(id . args) (not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
(syntax/loc stx (#%app tagged-impl . args))] (syntax/loc stx tagged-impl)]
[_else [(id . args)
(raise-syntax-error (syntax/loc stx (#%app tagged-impl . args))]
#f [_else
(string-append (raise-syntax-error
"this primitive operator must be applied to arguments; " #f
"expected an open parenthesis before the operator name") (string-append
stx)]))))])) "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-syntax (define-higher-order-primitive stx)
(define (is-proc-arg? arg) (define (is-proc-arg? arg)
@ -83,41 +88,45 @@
(implementation new-arg ...))]) (implementation new-arg ...))])
name)]) name)])
(syntax/loc stx (syntax/loc stx
(define-syntax (name s) (define-syntax name
(with-syntax ([tagged-impl (syntax-property (make-first-order
(syntax-property (quote-syntax impl) 'stepper-skip-completely #t) (lambda (s)
'stepper-prim-name (with-syntax ([tagged-impl (syntax-property
(quote-syntax name))]) (syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
(syntax-case s () 'stepper-prim-name
[(__ . ___) (quote-syntax name))])
;; HACK: see above (syntax-case s ()
(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)))
;; HACK: see above (syntax/loc s (tagged-impl . ___))]
(not (module-identifier=? #'beginner-app (datum->syntax-object s '#%app))) [__
(syntax/loc s tagged-impl)] ;; HACK: see above
[(__ new-arg ...) (not (module-identifier=? #'beginner-app (datum->syntax-object s '#%app)))
(begin (syntax/loc s tagged-impl)]
checks ... [(__ new-arg ...)
;; s is a well-formed use of the primitive; (begin
;; generate the primitive implementation checks ...
(syntax/loc s (tagged-impl wrapped-arg ...)) ;; s is a well-formed use of the primitive;
)] ;; generate the primitive implementation
[(__ . rest) (syntax/loc s (tagged-impl wrapped-arg ...))
(raise-syntax-error )]
#f [(__ . rest)
(format (raise-syntax-error
"primitive operator requires ~a arguments" #f
num-arguments) (format
s)] "primitive operator requires ~a arguments"
[_else num-arguments)
(raise-syntax-error s)]
#f [_else
(string-append (raise-syntax-error
"this primitive operator must be applied to arguments; " #f
"expected an open parenthesis before the operator name") (string-append
s)]))))))))])) "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) (define-syntax (fo->ho stx)
(syntax-case stx () (syntax-case stx ()

9
collects/lang/private/firstorder.ss
View File

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