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

76
collects/lang/prim.rkt
View File

@ -18,40 +18,50 @@
first-order->higher-order)
(define-syntax (define-primitive stx)
(define (go name implementation struct-info)
(with-syntax ([name name][implementation implementation])
(with-syntax ([impl #'(let ([name (lambda argv
(apply implementation argv))])
name)])
#`(begin
;; Make sure that `implementation' is bound:
(define-values () (begin (lambda () implementation) (values)))
;; Bind `name':
(define-syntax name
(#,(if struct-info
#'fo:make-first-order+struct
#'fo:make-first-order)
(lambda (stx)
(with-syntax ([tagged-impl (stepper-syntax-property
(stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
'stepper-prim-name
(quote-syntax name))])
(syntax-case stx ()
[(_ . body)
;; 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 . body))]
[_
;; HACK: see above
(not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
(syntax/loc stx tagged-impl)]
[(id . args)
(syntax/loc stx (#%plain-app tagged-impl . args))]
[_
(raise-syntax-error
#f
"expected a function call, but there is no open parenthesis before this function"
stx)])))
((syntax-local-certifier #t)
#'impl)
#,@(if struct-info
(list struct-info)
'())))))))
(syntax-case stx ()
[(_ name implementation)
(with-syntax ([impl #'(let ([name (lambda argv
(apply implementation argv))])
name)])
#'(begin
;; Make sure that `implementation' is bound:
(define-values () (begin (lambda () implementation) (values)))
;; Bind `name':
(define-syntax name
(fo:make-first-order
(lambda (stx)
(with-syntax ([tagged-impl (stepper-syntax-property
(stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
'stepper-prim-name
(quote-syntax name))])
(syntax-case stx ()
[(_ . body)
;; 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 . body))]
[_
;; HACK: see above
(not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
(syntax/loc stx tagged-impl)]
[(id . args)
(syntax/loc stx (#%plain-app tagged-impl . args))]
[_
(raise-syntax-error
#f
"expected a function call, but there is no open parenthesis before this function"
stx)])))
((syntax-local-certifier #t)
#'impl)))))]))
[(_ name implementation) (go #'name #'implementation #f)]
[(_ name implementation inf)
(go #'name #'implementation #'inf)]))
(define-syntax (define-higher-order-primitive stx)
(define (is-proc-arg? arg)

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

@ -1,23 +1,36 @@
(module firstorder mzscheme
(require racket/struct-info)
(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!)
(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+struct-proc-id (make-struct-field-accessor fo+struct-get 1))
(define (first-order->higher-order id)
(let ([v (syntax-local-value id (lambda () #f))])
(if (or (fo? v)
(if (or (fo-either? v)
(and (set!-transformer? v)
(fo? (set!-transformer-procedure v))))
(fo-either? (set!-transformer-procedure v))))
(syntax-property
(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
(syntax-local-introduce id))
id))))
id))))