From ccfc18829f73c166dda296e882879640bfa51e74 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 13 Jan 2009 05:57:01 +0000 Subject: [PATCH] stxclass: added call to internal-definition-seal in lib added static-of stxclass ported class-iop from macros planet package svn: r13086 --- .../macro-debugger/stxclass/private/lib.ss | 14 ++ .../macro-debugger/stxclass/private/rep.ss | 4 +- .../macro-debugger/stxclass/private/util.ss | 1 + collects/macro-debugger/util/class-ct.ss | 73 ++++++ collects/macro-debugger/util/class-iop.ss | 224 ++++++++++++++++++ 5 files changed, 315 insertions(+), 1 deletion(-) create mode 100644 collects/macro-debugger/util/class-ct.ss create mode 100644 collects/macro-debugger/util/class-iop.ss diff --git a/collects/macro-debugger/stxclass/private/lib.ss b/collects/macro-debugger/stxclass/private/lib.ss index 98f5654c4d..9dcc870013 100644 --- a/collects/macro-debugger/stxclass/private/lib.ss +++ b/collects/macro-debugger/stxclass/private/lib.ss @@ -69,6 +69,20 @@ #:pattern 'static #:reason "not an identifier")))) +(define-basic-syntax-class (static-of name pred) + ([value 0]) + (lambda (x name pred) + (let/ec escape + (define (bad) + (escape (fail-sc x + #:pattern 'name + #:reason (format "not bound as ~a" name)))) + (if (identifier? x) + (let ([value (syntax-local-value x bad)]) + (unless (pred value) (bad)) + (list value)) + (bad))))) + (define-basic-syntax-class struct-name ([descriptor 0] [constructor 0] diff --git a/collects/macro-debugger/stxclass/private/rep.ss b/collects/macro-debugger/stxclass/private/rep.ss index de868a0766..5e58646c4e 100644 --- a/collects/macro-debugger/stxclass/private/rep.ss +++ b/collects/macro-debugger/stxclass/private/rep.ss @@ -185,7 +185,9 @@ [args (cdr p)]) (unless (equal? (length (sc-inputs stxclass)) (length args)) (raise-syntax-error 'syntax-class - "too few arguments for syntax class" + (format "too few arguments for syntax class ~a (expected ~s)" + (sc-name stxclass) + (length (sc-inputs stxclass))) id)) (values id stxclass args (ssc? stxclass))))] [else (values id #f null #f)])) diff --git a/collects/macro-debugger/stxclass/private/util.ss b/collects/macro-debugger/stxclass/private/util.ss index efa24ed302..2b951dbd32 100644 --- a/collects/macro-debugger/stxclass/private/util.ss +++ b/collects/macro-debugger/stxclass/private/util.ss @@ -214,6 +214,7 @@ [_ (loop (stx-cdr x) (cons ee ex) #t)]))] [(stx-null? x) + (internal-definition-context-seal intdef) (reverse ex)])))) diff --git a/collects/macro-debugger/util/class-ct.ss b/collects/macro-debugger/util/class-ct.ss new file mode 100644 index 0000000000..473acbacfc --- /dev/null +++ b/collects/macro-debugger/util/class-ct.ss @@ -0,0 +1,73 @@ +#lang scheme/base +(require (for-template scheme/base + scheme/class) + macro-debugger/stxclass/stxclass) + +(provide static-interface? + make-static-interface + static-interface-dynamic + static-interface-members + + make-checked-binding + checked-binding? + checked-binding-dynamic + checked-binding-iface + + checked-binding + static-interface) + +(define-struct static-interface (dynamic members) + #:omit-define-syntaxes + #:property prop:procedure + (lambda (self stx) + (syntax-case stx () + [(ifname . args) + (datum->syntax stx (cons #'(#%expression ifname) #'args) stx)] + [ifname + (identifier? #'ifname) + (static-interface-dynamic self)]))) + +(define-struct raw-checked-binding (dynamic iface) + #:omit-define-syntaxes + #:property prop:procedure + (lambda (self stx) + (syntax-case stx (set!) + [(set! var expr) + #`(let ([newval expr]) + (unless (is-a? newval #,(static-interface-dynamic + (raw-checked-binding-iface self))) + (error 'check "interface check failed on: ~e" newval)) + (set! #,(raw-checked-binding-dynamic self) newval))] + [(var . args) + (datum->syntax stx (cons #'(#%expression var) #'args) stx)] + [var + (identifier? #'var) + (raw-checked-binding-dynamic self)] + [else + (raise-syntax-error #f "oops" stx)]))) + +(define (make-checked-binding dynamic iface) + (make-set!-transformer + (make-raw-checked-binding dynamic iface))) + +(define (checked-binding? x) + (and (set!-transformer? x) + (raw-checked-binding? (set!-transformer-procedure x)))) + +(define (checked-binding-dynamic x) + (raw-checked-binding-dynamic (set!-transformer-procedure x))) + +(define (checked-binding-iface x) + (raw-checked-binding-iface (set!-transformer-procedure x))) + +;; Syntax + +(define-syntax-class static-interface + (pattern x + #:declare x (static-of 'static-interface static-interface?) + #:with value #'x.value)) + +(define-syntax-class checked-binding + (pattern x + #:declare x (static-of 'checked-binding checked-binding?) + #:with value #'x.value)) diff --git a/collects/macro-debugger/util/class-iop.ss b/collects/macro-debugger/util/class-iop.ss new file mode 100644 index 0000000000..5985a795e3 --- /dev/null +++ b/collects/macro-debugger/util/class-iop.ss @@ -0,0 +1,224 @@ +#lang scheme/base +(require scheme/class + (for-syntax scheme/base + macro-debugger/stxclass/stxclass + ;; "stx.ss" + "class-ct.ss")) +(provide define-interface + define-interface/dynamic + + send: + send*: + send/apply: + + define: + lambda: + init: + init-private:) + +;; Configuration +(define-for-syntax warn-on-dynamic-interfaces? #f) +(define-for-syntax warn-on-dynamic-object-check-generation? #f) +(define-for-syntax warn-on-dynamic-object-check? #f) +(define-for-syntax define-dotted-names #f) + +;; define-interface SYNTAX +;; (define-interface NAME (IDENTIFIER ...)) +;; Defines NAME as an interface. +(define-syntax (define-interface stx) + (syntax-parse stx + [(_ name:id (mname:id ...)) + #'(define-interface/dynamic name + (let ([name (interface () mname ...)]) name) + (mname ...))])) + +;; define-interface/dynamic SYNTAX +;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...)) +;; Defines NAME as a static interface containing the names listed. +;; The EXPR is used as the dynamic componenent of the interface, and +;; it should contain a superset of the names listed. +(define-syntax (define-interface/dynamic stx) + (syntax-parse stx + [(_ name:id dynamic-interface:expr (mname:id ...)) + (with-syntax ([(dynamic-name) (generate-temporaries #'(name))]) + #'(begin (define dynamic-name + (let ([dynamic-name dynamic-interface]) + (for-each + (lambda (m) + (unless (method-in-interface? m dynamic-name) + (error 'name "dynamic interface missing method '~s'" m))) + '(mname ...)) + dynamic-name)) + (define-syntax name + (make-static-interface #'dynamic-name '(mname ...)))))])) + +;; Checked send + +(define-syntax (send: stx) + (syntax-parse stx + [(send: obj:expr iface:static-interface method:id . args) + #`(begin (check-method<-interface method iface) + #,(syntax/loc stx + (send (check-object<:interface send: obj iface) + method . args)))])) + +(define-syntax (send*: stx) + (syntax-parse stx + [(send*: obj:expr iface:static-interface (method:id . args) ...) + #`(begin (check-method<-interface method iface) ... + #,(syntax/loc stx + (send* (check-object<:interface send*: obj iface) + (method . args) ...)))])) + +(define-syntax (send/apply: stx) + (syntax-parse stx + [(send/apply: obj:expr iface:static-interface method:id . args) + #`(begin (check-method<-interface method iface) + #,(syntax/loc stx + (send/apply (check-object<:interface send/apply obj iface) + method . args)))])) + +;; + +;; check-method<-interface SYNTAX +(define-syntax (check-method<-interface stx) + (syntax-parse stx + [(check-method<-interface method:id iface:static-interface) + (let ([si #'iface.value]) + (unless (member (syntax-e #'method) (static-interface-members si)) + (raise-syntax-error 'checked-send + "method not in static interface" + #'method)) + #''okay)] + [(check-method<-interface method:id iface:expr) + (begin (when warn-on-dynamic-interfaces? + (printf "dynamic interface check: ~s,~s: method: ~a~n" + (syntax-source #'method) + (syntax-line #'method) + (syntax-e #'method))) + #`(let ([ifc iface]) + (unless (method-in-interface? 'method ifc) + (error 'checked-send + "interface does not contain method '~a': ~e" + 'method + ifc))))])) + +;; check-object<:interface SYNTAX +(define-syntax (check-object<:interface stx) + (syntax-parse stx + [(_ for-whom obj:checked-binding iface:static-interface) + (if (eq? (checked-binding-iface #'obj.value) #'iface.value) + #'obj + (syntax/loc stx + (check-object<:interface for-whom (#%expression obj) (#%expression iface))))] + [(_ for-whom obj:expr iface:expr) + (begin + (when warn-on-dynamic-object-check-generation? + (printf "dynamic object check: ~s,~s~n" + (syntax-source #'obj) + (syntax-line #'obj))) + #'(dynamic:check-object<:interface 'for-whom obj iface))])) + +(define (dynamic:check-object<:interface for-whom obj iface) + (unless (is-a? obj iface) + (error for-whom "interface check failed on: ~e" obj)) + (let-syntax ([x (lambda (stx) + (if warn-on-dynamic-object-check? + #'(printf "dynamic: object check passed~n") + #'(void)))]) + x) + obj) + +;; + +(define-syntax (define: stx) + (syntax-parse stx + [(_ name:id iface:static-interface expr) + (let ([si #'iface.value]) + (with-syntax ([(name-internal) (generate-temporaries #'(name))] + [(method ...) (static-interface-members si)] + [(name.method ...) + (map (lambda (m) + (datum->syntax #'name + (string->symbol (format "~a.~a" (syntax-e #'name) m)))) + (static-interface-members si))]) + #`(begin (define name-internal + (check-object<:interface define: expr iface)) + (define-syntax name + (make-checked-binding + #'name-internal + (syntax-local-value #'iface))) + #,(if define-dotted-names + #'(begin + (define-syntax name.method + (syntax-rules () + [(name.method . args) + (send: name iface method . args)])) + ...) + #'(begin)))))] + [(_ (f:id . args) . body) + #'(define f (lambda: args . body))])) + +(define-syntax (lambda: stx) + ;; FIXME: rewrite as stxclass + (define (arg->define stx temp) + (syntax-case stx () + [(arg : iface) + (and (identifier? #'arg) + (eq? ': (syntax-e #':))) + #`(define: arg iface #,temp)] + [arg + (identifier? #'arg) + #`(define-syntax arg (make-rename-transformer #'#,temp))])) + (syntax-parse stx + [(_ (arg ...) . body) + (let ([temporaries (generate-temporaries #'(arg ...))]) + (with-syntax ([(temp ...) temporaries] + [(checked-definition ...) + (map arg->define + (syntax->list #'(arg ...)) + temporaries)]) + #'(lambda (temp ...) + (let () + checked-definition ... + (let () . body)))))])) + +(define-syntax (init: stx) + (syntax-parse stx + [(_ (name:id iface:static-interface) ...) + #'(begin (init1: name iface) ...)])) + +(define-syntax (init1: stx) + (syntax-parse stx + [(_ name:id iface:static-interface) + (with-syntax ([(name-internal) (generate-temporaries #'(name))]) + #'(begin (init (name name-internal)) + (void (check-object<:interface init: name-internal iface)) + (define-syntax name + (make-checked-binding + #'name-internal + (syntax-local-value #'iface)))))])) + +(define-syntax (init-private stx) + (syntax-parse stx + [(init-private form ...) + #'(begin (init-private1 form) ...)])) + +(define-syntax (init-private1 stx) + (syntax-parse stx + [(init-private1 id:id) + (with-syntax ([(id-internal) (generate-temporaries #'(id))]) + #'(begin (init (id-internal id)) + (define id id-internal)))])) + +(define-syntax (init-private: stx) + (syntax-parse stx + [(_ (name:id iface:static-interface) ...) + #'(begin (init-private1: name iface) ...)])) + +(define-syntax (init-private1: stx) + (syntax-parse stx + [(_ name:id iface:static-interface) + (with-syntax ([(id-internal) (generate-temporaries #'(id))]) + #'(begin (init (id-internal name)) + (define: name iface id-internal)))]))