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

adjust define-primitive so that it cooperates with struct-info.

Browse Source 
Specifically, if there is a third argument to define-primitive, then
it uses the prop:struct-info setup, using that third argument
as the struct-info (in the list format).
This commit is contained in:
Robby Findler 2012-09-28 15:07:49 -05:00
parent 679c308c53
commit 8971cb5981
2 changed files with 68 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/lang/prim.rkt
View File

@ -18,17 +18,19 @@
first-order->higher-order) first-order->higher-order)
(define-syntax (define-primitive stx) (define-syntax (define-primitive stx)
(syntax-case stx () (define (go name implementation struct-info)
[(_ name implementation) (with-syntax ([name name][implementation implementation])
(with-syntax ([impl #'(let ([name (lambda argv (with-syntax ([impl #'(let ([name (lambda argv
(apply implementation argv))]) (apply implementation argv))])
name)]) name)])
#'(begin #`(begin
;; Make sure that `implementation' is bound: ;; Make sure that `implementation' is bound:
(define-values () (begin (lambda () implementation) (values))) (define-values () (begin (lambda () implementation) (values)))
;; Bind `name': ;; Bind `name':
(define-syntax name (define-syntax name
(fo:make-first-order (#,(if struct-info
#'fo:make-first-order+struct
#'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)
@ -51,7 +53,15 @@
"expected a function call, but there is no open parenthesis before this function" "expected a function call, but there is no open parenthesis before this function"
stx)]))) stx)])))
((syntax-local-certifier #t) ((syntax-local-certifier #t)
#'impl)))))])) #'impl)
#,@(if struct-info
(list struct-info)
'())))))))
(syntax-case stx ()
[(_ name implementation) (go #'name #'implementation #f)]
[(_ name implementation inf)
(go #'name #'implementation #'inf)]))
(define-syntax (define-higher-order-primitive stx) (define-syntax (define-higher-order-primitive stx)
(define (is-proc-arg? arg) (define (is-proc-arg? arg)

27
collects/lang/private/firstorder.rkt
View File

@ -1,23 +1,36 @@
(module firstorder mzscheme (module firstorder mzscheme
(require racket/struct-info)
(provide make-first-order (provide make-first-order
first-order->higher-order) make-first-order+struct
first-order->higher-order
fo+struct?
fo?)
(define (fo-either? x) (or (fo? x) (fo+struct? x)))
(define (fo-either-proc-id x)
(if (fo? x)
(fo-proc-id x)
(fo+struct-proc-id x)))
(define-values (struct:fo make-first-order fo? fo-get fo-set!) (define-values (struct:fo make-first-order fo? fo-get fo-set!)
(make-struct-type 'procedure #f 2 0 #f null (current-inspector) 0)) (make-struct-type 'procedure #f 2 0 #f null (current-inspector) 0))
(define-values (struct:fo+struct make-first-order+struct fo+struct? fo+struct-get fo+struct-set!)
(let ()
(define props (list (cons prop:struct-info (λ (s) (fo+struct-get s 2)))))
(make-struct-type 'procedure #f 3 0 #f props (current-inspector) 0)))
(define fo-proc-id (make-struct-field-accessor fo-get 1)) (define fo-proc-id (make-struct-field-accessor fo-get 1))
(define fo+struct-proc-id (make-struct-field-accessor fo+struct-get 1))
(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 (or (fo? v) (if (or (fo-either? v)
(and (set!-transformer? v) (and (set!-transformer? v)
(fo? (set!-transformer-procedure v)))) (fo-either? (set!-transformer-procedure v))))
(syntax-property (syntax-property
(syntax-local-introduce (syntax-local-introduce
(fo-proc-id (if (fo? v) v (set!-transformer-procedure v)))) (fo-either-proc-id (if (fo-either? v) v (set!-transformer-procedure v))))
'disappeared-use 'disappeared-use
(syntax-local-introduce id)) (syntax-local-introduce id))
id)))) id))))