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

Syncing up to trunk, including Matthew's fix.

Browse Source 
svn: r13099
This commit is contained in:
Stevie Strickland 2009-01-14 01:17:48 +00:00
commit 61ed9d9bf4
26 changed files with 623 additions and 280 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/lang/private/beginner-funs.ss
View File

@ -32,18 +32,18 @@
((beginner-* *) (num num num ... -> num)
"to compute the product of all of the input numbers")
((beginner-/ /) (num num num ... -> num)
"to divide the first by the second (and all following) number(s);"
"to divide the first by the second (and all following) number(s); try (/ 3 4) and (/ 3 2 2)"
" only the first number can be zero.")
(max (real real ... -> real)
"to determine the largest number")
(min (real real ... -> real)
"to determine the smallest number")
(quotient (int int -> int)
"to compute the quotient of two integers")
"to divide the first integer into the second; try (quotient 3 4) and (quotient 4 3)")
(remainder (int int -> int)
"to compute the remainder of dividing the first by the second integer")
"to determine the remainder of dividing the first by the second integer")
(modulo (int int -> int)
"to compute first number modulo second number")
"to find the remainder of the division of the first number by the second; try (modulo 4 3) (modulo 4 -3)")
(sqr (num -> num)
"to compute the square of a number")
(sqrt (num -> num)

14
collects/macro-debugger/stxclass/private/lib.ss
View File

@ -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]

2
collects/macro-debugger/stxclass/private/parse.ss
View File

@ -74,7 +74,7 @@
(with-syntax ([k k] [x x] [p p] [reason reason]
[fc-expr (frontier->expr fc)])
#`(let ([failcontext fc-expr])
(printf "failed: reason=~s, p=~s\n fc=~s\n" reason p failcontext)
#;(printf "failed: reason=~s, p=~s\n fc=~s\n" reason p failcontext)
(k x p 'reason failcontext))))
;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)

4
collects/macro-debugger/stxclass/private/rep.ss
View File

@ -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)]))

1
collects/macro-debugger/stxclass/private/util.ss
View File

@ -214,6 +214,7 @@
[_
(loop (stx-cdr x) (cons ee ex) #t)]))]
[(stx-null? x)
(internal-definition-context-seal intdef)
(reverse ex)]))))

5
collects/macro-debugger/syntax-browser/controller.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
"interfaces.ss"
"partition.ss"
"../util/notify.ss")
@ -31,7 +32,7 @@
(super-new)
(listen-selected-syntax
(lambda (new-value)
(for-each (lambda (display) (send display refresh))
(for-each (lambda (display) (send: display display<%> refresh))
displays)))))
;; mark-manager-mixin
@ -62,7 +63,7 @@
(new partition% (relation (cdr name+proc)))))))
(listen-secondary-partition
(lambda (p)
(for-each (lambda (d) (send d refresh))
(for-each (lambda (d) (send: d display<%> refresh))
displays)))
(super-new)))

45
collects/macro-debugger/syntax-browser/display.ss
View File

@ -3,6 +3,7 @@
(require scheme/class
scheme/gui
scheme/match
macro-debugger/util/class-iop
"pretty-printer.ss"
"interfaces.ss"
"util.ss")
@ -17,7 +18,7 @@
(define output-port (open-output-string/count-lines))
(define range
(pretty-print-syntax stx output-port
(send controller get-primary-partition)
(send: controller controller<%> get-primary-partition)
(send config get-colors)
(send config get-suffix-option)
columns))
@ -42,13 +43,14 @@
;; add-clickbacks : text% range% controller<%> number -> void
(define (add-clickbacks text range controller insertion-point)
(for ([range (send range all-ranges)])
(for ([range (send: range range<%> all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
(send text set-clickback (+ insertion-point start) (+ insertion-point end)
(lambda (_1 _2 _3)
(send controller set-selected-syntax stx))))))
(send: controller selection-manager<%>
set-selected-syntax stx))))))
;; set-standard-font : text% config number number -> void
(define (set-standard-font text config start end)
@ -81,7 +83,9 @@
(begin-edit-sequence)
(change-style unhighlight-d start-position end-position))
(apply-extra-styles)
(let ([selected-syntax (send controller get-selected-syntax)])
(let ([selected-syntax
(send: controller selection-manager<%>
get-selected-syntax)])
(apply-secondary-partition-styles selected-syntax)
(apply-selection-styles selected-syntax))
(send* text
@ -126,9 +130,11 @@
(let ([delta (new style-delta%)])
(send delta set-delta-foreground color)
delta))
(define color-styles (list->vector (map color-style (send config get-colors))))
(define color-styles
(list->vector (map color-style (send config get-colors))))
(define overflow-style (color-style "darkgray"))
(define color-partition (send controller get-primary-partition))
(define color-partition
(send: controller mark-manager<%> get-primary-partition))
(define offset start-position)
(for-each
(lambda (range)
@ -139,12 +145,12 @@
(primary-style stx color-partition color-styles overflow-style)
(+ offset start)
(+ offset end))))
(send range all-ranges)))
(send: range range<%> all-ranges)))
;; primary-style : syntax partition (vector-of style-delta%) style-delta%
;; -> style-delta%
(define/private (primary-style stx partition color-vector overflow)
(let ([n (send partition get-partition stx)])
(let ([n (send: partition partition<%> get-partition stx)])
(cond [(< n (vector-length color-vector))
(vector-ref color-vector n)]
[else
@ -157,7 +163,7 @@
;; Applies externally-added styles (such as highlighting)
(define/private (apply-extra-styles)
(for ([(stx style-deltas) extra-styles])
(for ([r (send range get-ranges stx)])
(for ([r (send: range range<%> get-ranges stx)])
(for ([style-delta style-deltas])
(restyle-range r style-delta)))))
@ -166,23 +172,25 @@
;; in the same partition in blue.
(define/private (apply-secondary-partition-styles selected-syntax)
(when (identifier? selected-syntax)
(let ([partition (send controller get-secondary-partition)])
(let ([partition
(send: controller secondary-partition<%>
get-secondary-partition)])
(when partition
(for-each (lambda (id)
(when (send partition same-partition? selected-syntax id)
(draw-secondary-connection id)))
(send range get-identifier-list))))))
(for ([id (send: range range<%> get-identifier-list)])
(when (send: partition partition<%>
same-partition? selected-syntax id)
(draw-secondary-connection id)))))))
;; apply-selection-styles : syntax -> void
;; Styles subterms eq to the selected syntax
(define/private (apply-selection-styles selected-syntax)
(let ([rs (send range get-ranges selected-syntax)])
(for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
(for ([r (send: range range<%> get-ranges selected-syntax)])
(restyle-range r select-highlight-d)))
;; draw-secondary-connection : syntax -> void
(define/private (draw-secondary-connection stx2)
(let ([rs (send range get-ranges stx2)])
(for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))
(for ([r (send range get-ranges stx2)])
(restyle-range r select-sub-highlight-d)))
;; restyle-range : (cons num num) style-delta% -> void
(define/private (restyle-range r style)
@ -258,4 +266,3 @@
(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
(define unhighlight-d (highlight-style-delta "white" #f))

6
collects/macro-debugger/syntax-browser/frame.ss
View File

@ -1,4 +1,3 @@
#lang scheme/base
(require scheme/class
scheme/gui
@ -20,10 +19,9 @@
;; browse-syntaxes : (list-of syntax) -> void
(define (browse-syntaxes stxs)
(let ((w (make-syntax-browser)))
(for-each (lambda (stx)
(for ([stx stxs])
(send w add-syntax stx)
(send w add-separator))
stxs)))
(send w add-separator))))
;; make-syntax-browser : -> syntax-browser<%>
(define (make-syntax-browser)

102
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -1,37 +1,33 @@
#lang scheme/base
(require scheme/class)
(require scheme/class
macro-debugger/util/class-iop)
(provide (all-defined-out))
;; displays-manager<%>
(define displays-manager<%>
(interface ()
;; add-syntax-display : display<%> -> void
(define-interface displays-manager<%>
(;; add-syntax-display : display<%> -> void
add-syntax-display
;; remove-all-syntax-displays : -> void
remove-all-syntax-displays))
;; selection-manager<%>
(define selection-manager<%>
(interface ()
;; selected-syntax : syntax/#f
(define-interface selection-manager<%>
(;; selected-syntax : syntax/#f
set-selected-syntax
get-selected-syntax
listen-selected-syntax
))
listen-selected-syntax))
;; mark-manager<%>
;; Manages marks, mappings from marks to colors
(define mark-manager<%>
(interface ()
;; get-primary-partition : -> partition
(define-interface mark-manager<%>
(;; get-primary-partition : -> partition
get-primary-partition))
;; secondary-partition<%>
(define secondary-partition<%>
(interface (displays-manager<%>)
;; get-secondary-partition : -> partition<%>
(define-interface secondary-partition<%>
(;; get-secondary-partition : -> partition<%>
get-secondary-partition
;; set-secondary-partition : partition<%> -> void
@ -50,32 +46,44 @@
listen-identifier=?))
;; controller<%>
(define controller<%>
(define-interface/dynamic controller<%>
(interface (displays-manager<%>
selection-manager<%>
mark-manager<%>
secondary-partition<%>)))
secondary-partition<%>))
(add-syntax-display
remove-all-syntax-displays
set-selected-syntax
get-selected-syntax
listen-selected-syntax
get-primary-partition
get-secondary-partition
set-secondary-partition
listen-secondary-partition
get-identifier=?
set-identifier=?
listen-identifier=?))
;; host<%>
(define host<%>
(interface ()
;; get-controller : -> controller<%>
(define-interface host<%>
(;; get-controller : -> controller<%>
get-controller
;; add-keymap : text snip
add-keymap
))
add-keymap))
;; display<%>
(define display<%>
(interface ()
;; refresh : -> void
(define-interface display<%>
(;; refresh : -> void
refresh
;; highlight-syntaxes : (list-of syntax) color -> void
highlight-syntaxes
;; underline-syntaxes : (listof syntax) -> void
underline-syntaxes
;; get-start-position : -> number
get-start-position
@ -86,9 +94,8 @@
get-range))
;; range<%>
(define range<%>
(interface ()
;; get-ranges : datum -> (list-of (cons number number))
(define-interface range<%>
(;; get-ranges : datum -> (list-of (cons number number))
get-ranges
;; all-ranges : (list-of Range)
@ -98,41 +105,37 @@
;; get-identifier-list : (list-of identifier)
get-identifier-list))
;; A Range is (make-range datum number number)
(define-struct range (obj start end))
;; syntax-prefs<%>
(define syntax-prefs<%>
(interface ()
pref:width
(define-interface syntax-prefs<%>
(pref:width
pref:height
pref:props-percentage
pref:props-shown?))
;; widget-hooks<%>
(define widget-hooks<%>
(interface ()
;; setup-keymap : -> void
(define-interface widget-hooks<%>
(;; setup-keymap : -> void
setup-keymap
;; shutdown : -> void
shutdown
))
shutdown))
;; keymap-hooks<%>
(define keymap-hooks<%>
(interface ()
;; make-context-menu : -> context-menu<%>
(define-interface keymap-hooks<%>
(;; make-context-menu : -> context-menu<%>
make-context-menu
;; get-context-menu% : -> class
get-context-menu%))
;; context-menu-hooks<%>
(define context-menu-hooks<%>
(interface ()
add-edit-items
(define-interface context-menu-hooks<%>
(add-edit-items
after-edit-items
add-selection-items
after-selection-items
@ -143,19 +146,16 @@
;;----------
;; Convenience widget, specialized for displaying stx and not much else
(define syntax-browser<%>
(interface ()
add-syntax
(define-interface syntax-browser<%>
(add-syntax
add-text
add-separator
erase-all
select-syntax
get-text
))
get-text))
(define partition<%>
(interface ()
;; get-partition : any -> number
(define-interface partition<%>
(;; get-partition : any -> number
get-partition
;; same-partition? : any any -> number

3
collects/macro-debugger/syntax-browser/properties.ss
View File

@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/class
scheme/gui
macro-debugger/util/class-iop
"interfaces.ss"
"util.ss"
"../util/mpi.ss")
@ -24,7 +25,7 @@
(field (text (new text%)))
(field (pdisplayer (new properties-displayer% (text text))))
(send controller listen-selected-syntax
(send: controller selection-manager<%> listen-selected-syntax
(lambda (stx)
(set! selected-syntax stx)
(refresh)))

20
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -6,6 +6,7 @@
scheme/list
scheme/match
syntax/boundmap
macro-debugger/util/class-iop
"interfaces.ss"
"controller.ss"
"display.ss"
@ -119,7 +120,8 @@
(let ([display (internal-add-syntax stx)]
[definite-table (make-hasheq)])
(for-each (lambda (hi-stxs hi-color)
(send display highlight-syntaxes hi-stxs hi-color))
(send: display display<%>
highlight-syntaxes hi-stxs hi-color))
hi-stxss
hi-colors)
(for ([definite definites])
@ -128,20 +130,20 @@
(for ([shifted-definite (hash-ref shift-table definite null)])
(hash-set! definite-table shifted-definite #t))))
(when alpha-table
(let ([range (send display get-range)]
[start (send display get-start-position)])
(let ([range (send: display display<%> get-range)]
[start (send: display display<%> get-start-position)])
(let* ([binders0
(module-identifier-mapping-map alpha-table (lambda (k v) k))]
[binders
(apply append (map get-binders binders0))])
(send display underline-syntaxes binders))
(for ([id (send range get-identifier-list)])
(send: display display<%> underline-syntaxes binders))
(for ([id (send: range range<%> get-identifier-list)])
(define definite? (hash-ref definite-table id #f))
(when #f ;; DISABLED
(add-binding-billboard start range id definite?))
(for ([binder (get-binders id)])
(for ([binder-r (send range get-ranges binder)])
(for ([id-r (send range get-ranges id)])
(for ([binder-r (send: range range<%> get-ranges binder)])
(for ([id-r (send: range range<%> get-ranges id)])
(add-binding-arrow start binder-r id-r definite?)))))))
(void)))
@ -169,7 +171,7 @@
(+ start (cdr id-r))
(string-append "from " (mpi->string src-mod))
(if definite? "blue" "purple")))
(send range get-ranges id))]
(send: range range<%> get-ranges id))]
[_ (void)]))
(define/public (add-separator)
@ -182,7 +184,7 @@
(with-unlock -text
(send -text erase)
(send -text delete-all-drawings))
(send controller remove-all-syntax-displays))
(send: controller displays-manager<%> remove-all-syntax-displays))
(define/public (get-text) -text)

73
collects/macro-debugger/util/class-ct.ss Normal file
View File

@ -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))

213
collects/macro-debugger/util/class-iop.ss Normal file
View File

@ -0,0 +1,213 @@
#lang scheme/base
(require scheme/class
(for-syntax scheme/base
macro-debugger/stxclass/stxclass
"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 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 ...)))))]))
;; Helper
(begin-for-syntax
(define (check-method-in-interface for-whom method si)
(unless (member (syntax-e method) (static-interface-members si))
(raise-syntax-error for-whom
"method not in static interface"
method))))
;; Checked send
(define-syntax (send: stx)
(syntax-parse stx
[(send: obj:expr iface:static-interface method:id . args)
(begin (check-method-in-interface 'send: #'method #'iface.value)
(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 (for ([method (syntax->list #'(method ...))])
(check-method-in-interface 'send*: method #'iface.value))
(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-in-interface 'send/apply: #'method #'iface.value)
(syntax/loc stx
(send/apply (check-object<:interface send/apply obj iface)
method . args)))]))
;;
;; 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))
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)))))]))
;; FIXME: unsafe due to mutation
(define-syntax (init-field: stx)
(syntax-parse stx
[(_ (name:id iface:static-interface) ...)
#'(begin (init1: init-field name iface) ...)]))
(define-syntax (init: stx)
(syntax-parse stx
[(_ (name:id iface:static-interface) ...)
#'(begin (init1: init name iface) ...)]))
(define-syntax (init1: stx)
(syntax-parse stx
[(_ init 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)))]))

78
collects/redex/private/rg-test.ss
View File

@ -495,11 +495,12 @@
#:var (list (λ _ 'x) (λ _ 'y))))
(term (λ (x) (hole y)))))
;; current-output : (-> (-> any) string)
(define (current-output thunk)
;; output : (-> (-> void) string)
(define (output thunk)
(let ([p (open-output-string)])
(parameterize ([current-output-port p])
(thunk))
(unless (void? (thunk))
(error 'output "expected void result")))
(begin0
(get-output-string p)
(close-output-port p))))
@ -510,28 +511,38 @@
(d 5)
(e e 4)
(n number))
(test (current-output (λ () (redex-check lang d #f)))
(test (output (λ () (redex-check lang d #f)))
"counterexample found after 1 attempts:\n5\n")
(test (redex-check lang d #t) #t)
(test (redex-check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t)
(test (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t)
(test (current-output (λ () (redex-check lang (d e) #f)))
(test (output (λ () (redex-check lang d #t))) "")
(test (output (λ () (redex-check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2)))
"")
(test (output (λ () (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2)))
"")
(test (output (λ () (redex-check lang (d e) #f)))
"counterexample found after 1 attempts:\n(5 4)\n")
(test (current-output (λ () (redex-check lang d (error 'pred-raised))))
"counterexample found after 1 attempts:\n5\n")
(let* ([p (open-output-string)]
[m (parameterize ([current-error-port p])
(with-handlers ([exn:fail? exn-message])
(redex-check lang d (error 'pred-raised))
'no-exn-raised))])
(test m "error: pred-raised")
(test (get-output-string p) #rx"checking 5 raises.*\n$")
(close-output-port p))
(test (parameterize ([check-randomness (make-random 0 0)])
(output
(λ ()
(redex-check lang n (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 42 x))))
#t)
(test (current-output
#:source (reduction-relation lang (--> 42 x))))))
"")
(test (output
(λ ()
(parameterize ([check-randomness (make-random 0 0)])
(redex-check lang n (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 0 x z))))))
"counterexample found (z) after 1 attempts:\n0\n")
(test (current-output
(test (output
(λ ()
(parameterize ([check-randomness (make-random 1)])
(redex-check lang d (eq? 42 (term n))
@ -539,19 +550,23 @@
#:source (reduction-relation lang (--> 0 x z))))))
"counterexample found after 1 attempts:\n5\n")
(test (let ([r (reduction-relation lang (--> 0 x z))])
(output
(λ ()
(redex-check lang n (number? (term n))
#:attempts 10
#:source r))
#t)
#:source r))))
"")
(let ()
(define-metafunction lang
[(mf 0) 0]
[(mf 42) 0])
(test (parameterize ([check-randomness (make-random 0 1)])
(output
(λ ()
(redex-check lang (n) (eq? 42 (term n))
#:attempts 1
#:source mf))
#t))
#:source mf))))
""))
(let ()
(define-language L)
(test (with-handlers ([exn:fail? exn-message])
@ -601,21 +616,21 @@
[(i any ...) (any ...)])
;; Dom(f) < Ctc(f)
(test (current-output
(test (output
(λ ()
(parameterize ([generation-decisions
(decisions #:num (list (λ _ 2) (λ _ 5)))])
(check-metafunction-contract f))))
"counterexample found after 1 attempts:\n(5)\n")
;; Rng(f) > Codom(f)
(test (current-output
(test (output
(λ ()
(parameterize ([generation-decisions
(decisions #:num (list (λ _ 3)))])
(check-metafunction-contract f))))
"counterexample found after 1 attempts:\n(3)\n")
;; LHS matches multiple ways
(test (current-output
(test (output
(λ ()
(parameterize ([generation-decisions
(decisions #:num (list (λ _ 1) (λ _ 1))
@ -623,9 +638,9 @@
(check-metafunction-contract g))))
"counterexample found after 1 attempts:\n(1 1)\n")
;; OK -- generated from Dom(h)
(test (check-metafunction-contract h) #t)
(test (output (λ () (check-metafunction-contract h))) "")
;; OK -- generated from pattern (any ...)
(test (check-metafunction-contract i #:attempts 5) #t))
(test (output (λ () (check-metafunction-contract i #:attempts 5))) ""))
;; check-reduction-relation
(let ()
@ -653,11 +668,11 @@
(reverse '((+ (+)) 0))))
(let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))])
(test (check-reduction-relation S (λ (x) #t) #:attempts 1) #t)
(test (current-output
(test (output (λ () (check-reduction-relation S (λ (x) #t) #:attempts 1))) "")
(test (output
(λ () (check-reduction-relation S (λ (x) #f))))
"counterexample found after 1 attempts with name:\n1\n")
(test (current-output
(test (output
(λ () (check-reduction-relation S (curry eq? 1))))
"counterexample found after 1 attempts with unnamed:\n3\n"))
@ -671,11 +686,13 @@
with
[(--> (9 a) b)
(==> a b)])])
(test (check-reduction-relation
(test (output
(λ ()
(check-reduction-relation
T (curry equal? '(9 4))
#:attempts 1
#:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x)))))
#t)))
#:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x)))))))
"")))
; check-metafunction
(let ()
@ -688,7 +705,8 @@
(check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1)
generated)
(reverse '((1) (2)))))
(test (current-output (λ () (check-metafunction m (curry eq? 1))))
(test (output (λ () (check-metafunction m (λ (_) #t)))) "")
(test (output (λ () (check-metafunction m (curry eq? 1))))
#rx"counterexample found after 1 attempts with clause #1")
(test (with-handlers ([exn:fail:contract? exn-message])
(check-metafunction m #t #:attempts 'NaN))

30
collects/redex/private/rg.ss
View File

@ -680,7 +680,7 @@ To do a better job of not generating programs with free variables,
(quasisyntax/loc stx
(let ([att attempts])
(assert-nat 'redex-check att)
(or (check-property
(check-property
(cons (list #,(term-generator #'lang #'pat #'random-decisions 'redex-check) #f)
(let ([lang-gen (generate lang (random-decisions lang))])
#,(if (not source-stx)
@ -714,7 +714,7 @@ To do a better job of not generating programs with free variables,
(if source (format " (~a) " source) " ") attempt)
(pretty-print term port))
(check-randomness))
(void))))))]))
(void)))))]))
(define (check-property gens-srcs match match-fail property attempts display [random random])
(let loop ([remaining attempts])
@ -729,7 +729,11 @@ To do a better job of not generating programs with free variables,
[(term bindings)
(generator (attempt->size attempt) attempt)])
(if (andmap (λ (bindings)
(with-handlers ([exn:fail? (λ (_) #f)])
(with-handlers ([exn:fail? (λ (exn)
(fprintf (current-error-port)
"checking ~s raises ~s\n"
term exn)
(raise exn))])
(property term bindings)))
(cond [(and match (match term))
=> (curry map (compose make-bindings match-bindings))]
@ -758,11 +762,14 @@ To do a better job of not generating programs with free variables,
(list (list ((generate lang (decisions lang)) (if dom dom '(any (... ...)))) #f))
#f
#f
(λ (t _) (begin (term (name ,@t)) #t))
(λ (t _)
(with-handlers ([exn:fail:redex? (λ (_) #f)])
(begin (term (name ,@t)) #t)))
att
(λ (term attempt _ port)
(fprintf port "counterexample found after ~a attempts:\n" attempt)
(pretty-print term port))))))]))
(pretty-print term port)))
(void))))]))
(define (check-property-many lang pats srcs prop decisions attempts)
(let ([lang-gen (generate lang (decisions lang))])
@ -777,7 +784,8 @@ To do a better job of not generating programs with free variables,
(λ (term attempt source port)
(fprintf port "counterexample found after ~a attempts with ~a:\n"
attempt source)
(pretty-print term port))))))
(pretty-print term port))))
(void)))
(define (metafunc-srcs m)
(build-list (length (metafunc-proc-lhs-pats m))
@ -792,14 +800,13 @@ To do a better job of not generating programs with free variables,
(syntax/loc stx
(let ([att attempts])
(assert-nat 'check-metafunction att)
(or (check-property-many
(check-property-many
(metafunc-proc-lang m)
(metafunc-proc-lhs-pats m)
(metafunc-srcs m)
property
(generation-decisions)
att)
(void)))))]))
att))))]))
(define (reduction-relation-srcs r)
(map (λ (proc) (or (rewrite-proc-name proc) 'unnamed))
@ -809,14 +816,13 @@ To do a better job of not generating programs with free variables,
relation property
#:decisions [decisions random-decisions]
#:attempts [attempts default-check-attempts])
(or (check-property-many
(check-property-many
(reduction-relation-lang relation)
(map rewrite-proc-lhs (reduction-relation-make-procs relation))
(reduction-relation-srcs relation)
property
decisions
attempts)
(void)))
attempts))
(define-signature decisions^
(next-variable-decision

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "12jan2009")
#lang scheme/base (provide stamp) (define stamp "13jan2009")

4
src/mzscheme/src/env.c
View File

@ -2609,6 +2609,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
if (SCHEME_FALSEP(val)) {
/* Corresponds to a run-time binding (but will be replaced later
through a renaming to a different binding) */
if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL)
return scheme_make_local(scheme_local_type, 0, 0);
return NULL;
}
@ -2647,6 +2649,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
if (!(flags & SCHEME_OUT_OF_CONTEXT_OK))
scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id,
"identifier used out of context");
if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL)
return scheme_make_local(scheme_local_type, 0, 0);
return NULL;
}
}

8
src/mzscheme/src/eval.c
View File

@ -5379,7 +5379,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
? SCHEME_RESOLVE_MODIDS
: 0)
+ ((!rec[drec].comp && (rec[drec].depth == -2))
? SCHEME_OUT_OF_CONTEXT_OK
? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
: 0),
rec[drec].certs, env->in_modidx,
&menv, &protected, &lexical_binding_id);
@ -5486,7 +5486,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
? SCHEME_RESOLVE_MODIDS
: 0)
+ ((!rec[drec].comp && (rec[drec].depth == -2))
? SCHEME_OUT_OF_CONTEXT_OK
? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
: 0),
erec1.certs, env->in_modidx,
&menv, NULL, NULL);
@ -5572,7 +5572,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
+ SCHEME_DONT_MARK_USE
+ ((!rec[drec].comp && (rec[drec].depth == -2))
? SCHEME_OUT_OF_CONTEXT_OK
? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
: 0),
rec[drec].certs, env->in_modidx,
&menv, NULL, NULL);
@ -5615,7 +5615,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
+ SCHEME_DONT_MARK_USE
+ ((!rec[drec].comp && (rec[drec].depth == -2))
? SCHEME_OUT_OF_CONTEXT_OK
? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
: 0),
rec[drec].certs, env->in_modidx,
&menv, NULL, NULL);

1
src/mzscheme/src/schpriv.h
View File

@ -2350,6 +2350,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
#define SCHEME_RESOLVE_MODIDS 1024
#define SCHEME_NO_CERT_CHECKS 2048
#define SCHEME_REFERENCING 4096
#define SCHEME_OUT_OF_CONTEXT_LOCAL 8192
Scheme_Hash_Table *scheme_map_constants_to_globals(void);

20
src/mzscheme/src/stxobj.c
View File

@ -3109,6 +3109,14 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx)
return scheme_false;
}
#define EXPLAIN_RESOLVE 0
#if EXPLAIN_RESOLVE
static int explain_resolves = 1;
# define EXPLAIN(x) if (explain_resolves) { x; }
#else
# define EXPLAIN(x) /* empty */
#endif
static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env)
/* Compares the marks in two wraps lists. A result of 2 means that the
result depended on a barrier env. For a rib-based renaming, we need
@ -3273,6 +3281,7 @@ static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env
/* Done if both reached the end: */
if (WRAP_POS_END_P(awl) && WRAP_POS_END_P(bwl)) {
EXPLAIN(fprintf(stderr, " %d vs. %d marks\n", a_mark_cnt, b_mark_cnt));
if (a_mark_cnt == b_mark_cnt) {
while (a_mark_cnt--) {
if (!SAME_OBJ(a_mark_stack[a_mark_cnt], b_mark_stack[a_mark_cnt]))
@ -3364,14 +3373,6 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks)
}
}
#define EXPLAIN_RESOLVE 0
#if EXPLAIN_RESOLVE
static int explain_resolves = 0;
# define EXPLAIN(x) if (explain_resolves) { x; }
#else
# define EXPLAIN(x) /* empty */
#endif
static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth)
{
int l1, l2;
@ -3898,8 +3899,9 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
is_rib = NULL;
}
EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d%s\n", depth, is_rib ? 1 : 0,
EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d %s%s\n", depth, is_rib ? 1 : 0,
SCHEME_VEC_SIZE(rename),
SCHEME_SYMBOLP(SCHEME_VEC_ELS(rename)[0]) ? SCHEME_SYM_VAL(SCHEME_VEC_ELS(rename)[0]) : "<simp>",
SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1]) ? "" : " hash"));
c = SCHEME_RENAME_LEN(rename);

2
src/worksp/mred/mred.manifest
View File

@ -1,7 +1,7 @@
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
version="4.1.3.9"
version="4.1.3.10"
processorArchitecture="X86"
name="Org.PLT-Scheme.MrEd"
type="win32"

8
src/worksp/mred/mred.rc
View File

@ -20,8 +20,8 @@ APPLICATION ICON DISCARDABLE "mred.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,9
PRODUCTVERSION 4,1,3,9
FILEVERSION 4,1,3,10
PRODUCTVERSION 4,1,3,10
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -39,11 +39,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme GUI application\0"
VALUE "InternalName", "MrEd\0"
VALUE "FileVersion", "4, 1, 3, 9\0"
VALUE "FileVersion", "4, 1, 3, 10\0"
VALUE "LegalCopyright", "Copyright © 1995-2009\0"
VALUE "OriginalFilename", "MrEd.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 9\0"
VALUE "ProductVersion", "4, 1, 3, 10\0"
END
END
BLOCK "VarFileInfo"

8
src/worksp/mzcom/mzcom.rc
View File

@ -53,8 +53,8 @@ END
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,9
PRODUCTVERSION 4,1,3,9
FILEVERSION 4,1,3,10
PRODUCTVERSION 4,1,3,10
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -70,12 +70,12 @@ BEGIN
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "MzCOM Module"
VALUE "FileVersion", "4, 1, 3, 9"
VALUE "FileVersion", "4, 1, 3, 10"
VALUE "InternalName", "MzCOM"
VALUE "LegalCopyright", "Copyright 2000-2009 PLT (Paul Steckler)"
VALUE "OriginalFilename", "MzCOM.EXE"
VALUE "ProductName", "MzCOM Module"
VALUE "ProductVersion", "4, 1, 3, 9"
VALUE "ProductVersion", "4, 1, 3, 10"
END
END
BLOCK "VarFileInfo"

6
src/worksp/mzcom/mzobj.rgs
View File

@ -1,19 +1,19 @@
HKCR
{
MzCOM.MzObj.4.1.3.9 = s 'MzObj Class'
MzCOM.MzObj.4.1.3.10 = s 'MzObj Class'
{
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
}
MzCOM.MzObj = s 'MzObj Class'
{
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
CurVer = s 'MzCOM.MzObj.4.1.3.9'
CurVer = s 'MzCOM.MzObj.4.1.3.10'
}
NoRemove CLSID
{
ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
{
ProgID = s 'MzCOM.MzObj.4.1.3.9'
ProgID = s 'MzCOM.MzObj.4.1.3.10'
VersionIndependentProgID = s 'MzCOM.MzObj'
ForceRemove 'Programmable'
LocalServer32 = s '%MODULE%'

8
src/worksp/mzscheme/mzscheme.rc
View File

@ -29,8 +29,8 @@ APPLICATION ICON DISCARDABLE "mzscheme.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,9
PRODUCTVERSION 4,1,3,9
FILEVERSION 4,1,3,10
PRODUCTVERSION 4,1,3,10
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -48,11 +48,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme application\0"
VALUE "InternalName", "MzScheme\0"
VALUE "FileVersion", "4, 1, 3, 9\0"
VALUE "FileVersion", "4, 1, 3, 10\0"
VALUE "LegalCopyright", "Copyright <20>© 1995-2009\0"
VALUE "OriginalFilename", "mzscheme.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 9\0"
VALUE "ProductVersion", "4, 1, 3, 10\0"
END
END
BLOCK "VarFileInfo"

8
src/worksp/starters/start.rc
View File

@ -22,8 +22,8 @@ APPLICATION ICON DISCARDABLE "mzstart.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,3,9
PRODUCTVERSION 4,1,3,9
FILEVERSION 4,1,3,10
PRODUCTVERSION 4,1,3,10
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -45,7 +45,7 @@ BEGIN
#ifdef MZSTART
VALUE "FileDescription", "PLT Scheme Launcher\0"
#endif
VALUE "FileVersion", "4, 1, 3, 9\0"
VALUE "FileVersion", "4, 1, 3, 10\0"
#ifdef MRSTART
VALUE "InternalName", "mrstart\0"
#endif
@ -60,7 +60,7 @@ BEGIN
VALUE "OriginalFilename", "MzStart.exe\0"
#endif
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 3, 9\0"
VALUE "ProductVersion", "4, 1, 3, 10\0"
END
END
BLOCK "VarFileInfo"