merge to trunk
svn: r17877
This commit is contained in:
Sam Tobin-Hochstadt
parent
bbc195c0fb
commit
9789615ed9
|
|
@ -1498,34 +1498,36 @@
|
|||
;; and that normalization doesn't introduce new structs
|
||||
;;
|
||||
|
||||
(define (random-image size)
|
||||
(let loop ([size size])
|
||||
(let ([val (random (if (zero? size) 4 8))])
|
||||
(case val
|
||||
[(0) (rectangle (random-size) (random-size) (random-mode) (random-color))]
|
||||
[(1) (circle (random-size) (random-mode) (random-color))]
|
||||
[(2) (line (random-coord) (random-coord) (random-color))]
|
||||
[(3) (add-curve
|
||||
(rectangle (random-size) (random-size) (random-mode) (random-color))
|
||||
(random-coord) (random-coord) (random-pull) (random-angle)
|
||||
(random-coord) (random-coord) (random-pull) (random-angle)
|
||||
(random-color))]
|
||||
[(4) (overlay (loop (floor (/ size 2)))
|
||||
(loop (ceiling (/ size 2))))]
|
||||
[(5) (crop (random-coord) (random-coord) (random-size) (random-size)
|
||||
(loop (- size 1)))]
|
||||
[(6) (scale/xy (random-size)
|
||||
(random-size)
|
||||
(loop (- size 1)))]
|
||||
[(7) (rotate (random-angle) (loop (- size 1)))]))))
|
||||
(require redex/reduction-semantics)
|
||||
|
||||
(define (random-pull) (/ (random 20) (+ 1 (random 10))))
|
||||
(define (random-angle) (random 360))
|
||||
(define (random-coord) (- (random 200) 100))
|
||||
(define (random-size) (random 100))
|
||||
(define (random-mode) (if (zero? (random 2)) 'outline 'solid))
|
||||
(define (random-color) (pick-from-list '("red" red "blue" "orange" "green" "black")))
|
||||
(define (pick-from-list l) (list-ref l (random (length l))))
|
||||
(define-language 2htdp/image
|
||||
(image (rectangle size size mode color)
|
||||
(line coord coord color)
|
||||
(add-curve (rectangle size size mode color)
|
||||
coord coord pull angle
|
||||
coord coord pull angle
|
||||
color)
|
||||
(overlay image image)
|
||||
(overlay/xy image coord coord image)
|
||||
(underlay image image)
|
||||
(underlay/xy image coord coord image)
|
||||
(crop coord coord size size image)
|
||||
(scale/xy size size image)
|
||||
(scale size image)
|
||||
(rotate angle image))
|
||||
|
||||
(size big-nat)
|
||||
(mode 'outline 'solid "outline" "solid")
|
||||
(color "red" 'red "blue" "orange" "green" "black")
|
||||
(coord big-int)
|
||||
(pull 0 1/2 1/3 2 (/ big-nat (+ 1 big-nat)))
|
||||
(angle 0 90 45 30 180 natural (* 4 natural))
|
||||
|
||||
; Redex tends to choose small numbers.
|
||||
(big-nat (+ (* 10 natural) natural))
|
||||
(big-int (+ (* 10 integer) integer)))
|
||||
|
||||
(define-namespace-anchor anchor)
|
||||
|
||||
(define (image-struct-count obj)
|
||||
(let ([counts (make-hash)])
|
||||
|
|
@ -1535,21 +1537,25 @@
|
|||
(unless (member (car stuff) '(struct:translate struct:scale)) ;; skip these becuase normalization eliminates them
|
||||
(hash-set! counts (car stuff) (+ 1 (hash-ref counts (car stuff) 0))))
|
||||
(for-each loop (cdr stuff)))))
|
||||
(sort (hash-map counts list) string<=? #:key (λ (x) (symbol->string (car x))))))
|
||||
(sort (hash-map counts list) string<=? #:key (λ (x) (symbol->string (car x))))))
|
||||
|
||||
(define (check-image-properties img-sexp img)
|
||||
(let* ([raw-size (image-struct-count (image-shape img))]
|
||||
[normalized (normalize-shape (image-shape img) values)]
|
||||
[norm-size (image-struct-count normalized)])
|
||||
(unless (normalized-shape? normalized)
|
||||
(error 'test-image.ss "found a non-normalized shape after normalization:\n~s"
|
||||
img-sexp))
|
||||
(unless (equal? norm-size raw-size)
|
||||
(error 'test-image.ss "found differing sizes for ~s:\n ~s\n ~s"
|
||||
img-sexp raw-size norm-size))))
|
||||
|
||||
(time
|
||||
(let ([seed (+ 1 (modulo (current-seconds) (- (expt 2 31) 1)))])
|
||||
(random-seed seed)
|
||||
(for ((i (in-range 0 20000)))
|
||||
(let* ([img (random-image 10)]
|
||||
[raw-size (image-struct-count (image-shape img))]
|
||||
[normalized (normalize-shape (image-shape img) values)]
|
||||
[norm-size (image-struct-count normalized)])
|
||||
(unless (normalized-shape? normalized)
|
||||
(error 'test-image.ss "found a non-normalized shape (seed ~a) after normalization ~s:"
|
||||
seed
|
||||
img))
|
||||
(unless (equal? norm-size raw-size)
|
||||
(error 'test-image.ss "found differing sizes (seed ~a):\n ~s\n ~s"
|
||||
seed
|
||||
raw-size norm-size))))))
|
||||
(redex-check
|
||||
2htdp/image
|
||||
image
|
||||
(check-image-properties
|
||||
(term image)
|
||||
(eval (term image) (namespace-anchor->namespace anchor)))
|
||||
#:attempts 1000))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang typed-scheme
|
||||
#lang typed-scheme/no-check
|
||||
|
||||
(require typed/framework/framework
|
||||
typed/mred/mred
|
||||
(require framework/framework
|
||||
mred/mred
|
||||
scheme/class)
|
||||
|
||||
(provide pick-new-language looks-like-module?)
|
||||
|
|
|
|||
|
|
@ -78,6 +78,9 @@
|
|||
(set-splash-char-observer
|
||||
(λ (evt)
|
||||
(let ([ch (send evt get-key-code)])
|
||||
(when (and (eq? ch #\q)
|
||||
(send evt get-control-down))
|
||||
(exit))
|
||||
(when (char? ch)
|
||||
;; as soon as something is typed, load the bitmaps
|
||||
(load-magic-images)
|
||||
|
|
|
|||
|
|
@ -300,108 +300,98 @@
|
|||
;; asks the user for a .plt file, either from the web or from
|
||||
;; a file on the disk and installs it.
|
||||
(define (install-plt-file parent)
|
||||
(define pref (preferences:get 'drscheme:install-plt-dialog))
|
||||
(define dialog
|
||||
(instantiate dialog% ()
|
||||
(parent parent)
|
||||
(alignment '(left center))
|
||||
(label (string-constant install-plt-file-dialog-title))))
|
||||
(new dialog% [parent parent]
|
||||
[label (string-constant install-plt-file-dialog-title)]
|
||||
[alignment '(left center)]))
|
||||
(define tab-panel
|
||||
(instantiate tab-panel% ()
|
||||
(parent dialog)
|
||||
(callback (λ (x y) (update-panels)))
|
||||
(choices (list (string-constant install-plt-web-tab)
|
||||
(string-constant install-plt-file-tab)))))
|
||||
(define outer-swapping-panel (instantiate horizontal-panel% ()
|
||||
(parent tab-panel)
|
||||
(stretchable-height #f)))
|
||||
(define spacing-panel (instantiate horizontal-panel% ()
|
||||
(stretchable-width #f)
|
||||
(parent outer-swapping-panel)
|
||||
(min-width 20)))
|
||||
(define swapping-panel (instantiate panel:single% ()
|
||||
(parent outer-swapping-panel)
|
||||
(alignment '(left center))
|
||||
(stretchable-width #t)
|
||||
(stretchable-height #f)))
|
||||
(define file-panel (instantiate horizontal-panel% ()
|
||||
(parent swapping-panel)
|
||||
(stretchable-width #t)
|
||||
(stretchable-height #f)))
|
||||
(define url-panel (instantiate horizontal-panel% ()
|
||||
(parent swapping-panel)
|
||||
(stretchable-height #f)))
|
||||
(define button-panel (instantiate horizontal-panel% ()
|
||||
(parent dialog)
|
||||
(stretchable-height #f)
|
||||
(alignment '(right center))))
|
||||
(define file-text-field (instantiate text-field% ()
|
||||
(parent file-panel)
|
||||
(callback void)
|
||||
(min-width 300)
|
||||
(stretchable-width #t)
|
||||
(label (string-constant install-plt-filename))))
|
||||
(define file-button (instantiate button% ()
|
||||
(parent file-panel)
|
||||
(label (string-constant browse...))
|
||||
(callback (λ (x y) (browse)))))
|
||||
(define url-text-field (instantiate text-field% ()
|
||||
(parent url-panel)
|
||||
(label (string-constant install-plt-url))
|
||||
(min-width 300)
|
||||
(stretchable-width #t)
|
||||
(callback void)))
|
||||
|
||||
(new tab-panel% [parent dialog]
|
||||
[callback (λ (x y) (update-panels))]
|
||||
[choices (list (string-constant install-plt-web-tab)
|
||||
(string-constant install-plt-file-tab))]))
|
||||
(define outer-swapping-panel
|
||||
(new horizontal-panel% [parent tab-panel]
|
||||
[stretchable-height #f]))
|
||||
(define spacing-panel
|
||||
(new horizontal-panel% [parent outer-swapping-panel]
|
||||
[stretchable-width #f]
|
||||
[min-width 20]))
|
||||
(define swapping-panel
|
||||
(new panel:single% [parent outer-swapping-panel]
|
||||
[alignment '(left center)]
|
||||
[stretchable-width #t] [stretchable-height #f]))
|
||||
(define file-panel
|
||||
(new horizontal-panel% [parent swapping-panel]
|
||||
[stretchable-width #t] [stretchable-height #f]))
|
||||
(define url-panel
|
||||
(new horizontal-panel% [parent swapping-panel]
|
||||
[stretchable-height #f]))
|
||||
(define button-panel
|
||||
(new horizontal-panel% [parent dialog]
|
||||
[stretchable-height #f] [alignment '(right center)]))
|
||||
(define file-text-field
|
||||
(new text-field% [parent file-panel]
|
||||
[callback void] [min-width 300] [stretchable-width #t]
|
||||
[init-value (caddr pref)]
|
||||
[label (string-constant install-plt-filename)]))
|
||||
(define file-button
|
||||
(new button% [parent file-panel]
|
||||
[callback (λ (x y) (browse))]
|
||||
[label (string-constant browse...)]))
|
||||
(define url-text-field
|
||||
(new text-field% [parent url-panel]
|
||||
[min-width 300] [stretchable-width #t] [callback void]
|
||||
[init-value (cadr pref)]
|
||||
[label (string-constant install-plt-url)]))
|
||||
(define-values (ok-button cancel-button)
|
||||
(gui-utils:ok/cancel-buttons
|
||||
button-panel
|
||||
(λ (x y)
|
||||
(set! cancel? #f)
|
||||
(send dialog show #f))
|
||||
(λ (x y)
|
||||
(send dialog show #f))))
|
||||
|
||||
(λ (x y) (set! cancel? #f) (send dialog show #f))
|
||||
(λ (x y) (send dialog show #f))))
|
||||
;; browse : -> void
|
||||
;; gets the name of a file from the user and
|
||||
;; updates file-text-field
|
||||
;; gets the name of a file from the user and updates file-text-field
|
||||
(define (browse)
|
||||
(let ([filename (finder:get-file #f "" #f "" dialog)])
|
||||
(when filename
|
||||
(send file-text-field set-value (path->string filename)))))
|
||||
|
||||
;; from-web? : -> boolean
|
||||
;; returns #t if the user has selected a web address
|
||||
(define (from-web?)
|
||||
(zero? (send tab-panel get-selection)))
|
||||
|
||||
(define cancel? #t)
|
||||
|
||||
(define (update-panels)
|
||||
(send swapping-panel active-child
|
||||
(if (from-web?)
|
||||
url-panel
|
||||
file-panel)))
|
||||
|
||||
(define w? (from-web?))
|
||||
(define t (if w? url-text-field file-text-field))
|
||||
(send swapping-panel active-child (if w? url-panel file-panel))
|
||||
(send t focus)
|
||||
(send (send t get-editor) set-position
|
||||
0 (string-length (send t get-value))))
|
||||
;; initialize
|
||||
(send tab-panel set-selection (if (car pref) 0 1))
|
||||
(update-panels)
|
||||
(send dialog show #t)
|
||||
|
||||
(preferences:set 'drscheme:install-plt-dialog
|
||||
(list (from-web?)
|
||||
(send url-text-field get-value)
|
||||
(send file-text-field get-value)))
|
||||
(cond
|
||||
[cancel? (void)]
|
||||
[(from-web?)
|
||||
(install-plt-from-url (trim-whitespace (send url-text-field get-value)) parent)]
|
||||
[else
|
||||
(parameterize ([error-display-handler drscheme:init:original-error-display-handler])
|
||||
(run-installer (string->path (send file-text-field get-value))))]))
|
||||
|
||||
;; trim-whitespace: string -> string
|
||||
;; Trims the whitespace surrounding a string.
|
||||
(define (trim-whitespace a-str)
|
||||
(cond
|
||||
[(regexp-match #px"^\\s*(.*[^\\s])\\s*$"
|
||||
a-str)
|
||||
=> second]
|
||||
[else
|
||||
a-str]))
|
||||
|
||||
(install-plt-from-url
|
||||
(let* ([url (send url-text-field get-value)]
|
||||
;; trim whitespaces
|
||||
[url (regexp-replace #rx"^ +" url "")]
|
||||
[url (regexp-replace #rx" +$" url "")])
|
||||
(if (regexp-match? #rx"^(?:[^/:]*://|$)" url)
|
||||
url
|
||||
(string-append "http://" url)))
|
||||
parent)]
|
||||
[else (parameterize ([error-display-handler
|
||||
drscheme:init:original-error-display-handler])
|
||||
(run-installer
|
||||
(string->path (send file-text-field get-value))))]))
|
||||
|
||||
;; install-plt-from-url : string (union #f dialog%) -> void
|
||||
;; downloads and installs a .plt file from the given url
|
||||
(define (install-plt-from-url s-url parent)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang typed-scheme
|
||||
#lang typed-scheme/no-check
|
||||
|
||||
(require typed/mred/mred
|
||||
typed/framework/framework
|
||||
(require mred/mred
|
||||
framework/framework
|
||||
scheme/class
|
||||
string-constants/string-constant)
|
||||
|
||||
|
|
|
|||
|
|
@ -19,6 +19,11 @@
|
|||
(define original-output (current-output-port))
|
||||
(define (printfo . args) (apply fprintf original-output args))
|
||||
|
||||
(define sc-use-language-in-source "Use the language declared in the source")
|
||||
(define sc-choose-a-language "Choose a language")
|
||||
(define sc-lang-in-source-discussion
|
||||
"Typically, a #lang line at the start of a program declares its language. This is the default and preferred mode for DrScheme.")
|
||||
|
||||
(provide language-configuration@)
|
||||
|
||||
(define-unit language-configuration@
|
||||
|
|
@ -358,7 +363,42 @@
|
|||
(send this on-click-always #t)))
|
||||
|
||||
(define outermost-panel (make-object horizontal-pane% parent))
|
||||
(define languages-hier-list (make-object selectable-hierlist% outermost-panel))
|
||||
(define languages-choice-panel (new vertical-panel%
|
||||
[parent outermost-panel]
|
||||
[alignment '(left top)]))
|
||||
|
||||
(define use-language-in-source-rb
|
||||
(new radio-box%
|
||||
[label #f]
|
||||
[choices (list sc-use-language-in-source)]
|
||||
[parent languages-choice-panel]
|
||||
[callback
|
||||
(λ (rb evt)
|
||||
(module-language-selected)
|
||||
(send use-chosen-language-rb set-selection #f))]))
|
||||
(define in-source-discussion-panel (new horizontal-panel%
|
||||
[parent languages-choice-panel]
|
||||
[stretchable-height #f]))
|
||||
(define in-source-discussion-spacer (new horizontal-panel%
|
||||
[parent in-source-discussion-panel]
|
||||
[stretchable-width #f]
|
||||
[min-width 24]))
|
||||
(define stupid-internal-definition-syntax1 (add-discussion in-source-discussion-panel))
|
||||
(define use-chosen-language-rb
|
||||
(new radio-box%
|
||||
[label #f]
|
||||
[choices (list sc-choose-a-language)]
|
||||
[parent languages-choice-panel]
|
||||
[callback
|
||||
(λ (this-rb evt)
|
||||
(send use-language-in-source-rb set-selection #f))]))
|
||||
(define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel]))
|
||||
(define languages-hier-list-spacer (new horizontal-panel%
|
||||
[parent languages-hier-list-panel]
|
||||
[stretchable-width #f]
|
||||
[min-width 24]))
|
||||
|
||||
(define languages-hier-list (make-object selectable-hierlist% languages-hier-list-panel))
|
||||
(define details-outer-panel (make-object vertical-pane% outermost-panel))
|
||||
(define details/manual-parent-panel (make-object vertical-panel% details-outer-panel))
|
||||
(define details-panel (make-object panel:single% details/manual-parent-panel))
|
||||
|
|
@ -395,15 +435,31 @@
|
|||
(init-rest args)
|
||||
(public selected)
|
||||
(define (selected)
|
||||
(let ([ldp (get-language-details-panel)])
|
||||
(when ldp
|
||||
(send details-panel active-child ldp)))
|
||||
(send one-line-summary-message set-label (send language get-one-line-summary))
|
||||
(send revert-to-defaults-button enable #t)
|
||||
(set! get/set-selected-language-settings get/set-settings)
|
||||
(set! selected-language language))
|
||||
(send use-chosen-language-rb set-selection 0)
|
||||
(send use-language-in-source-rb set-selection #f)
|
||||
(update-gui-based-on-selected-language language get-language-details-panel get/set-settings))
|
||||
(apply super-make-object args))))
|
||||
|
||||
(define (update-gui-based-on-selected-language language get-language-details-panel get/set-settings)
|
||||
(let ([ldp (get-language-details-panel)])
|
||||
(when ldp
|
||||
(send details-panel active-child ldp)))
|
||||
(send one-line-summary-message set-label (send language get-one-line-summary))
|
||||
(send revert-to-defaults-button enable #t)
|
||||
(set! get/set-selected-language-settings get/set-settings)
|
||||
(set! selected-language language))
|
||||
|
||||
(define (module-language-selected)
|
||||
;; need to deselect things in the languages-hier-list at this point.
|
||||
;(send languages-hier-list select #f)
|
||||
(update-gui-based-on-selected-language module-language*language
|
||||
module-language*get-language-details-panel
|
||||
module-language*get/set-settings))
|
||||
|
||||
(define module-language*language 'module-language*-not-yet-set)
|
||||
(define module-language*get-language-details-panel 'module-language*-not-yet-set)
|
||||
(define module-language*get/set-settings 'module-language*-not-yet-set)
|
||||
|
||||
;; nothing-selected : -> void
|
||||
;; updates the GUI and selected-language and get/set-selected-language-settings
|
||||
;; for when no language is selected.
|
||||
|
|
@ -488,17 +544,7 @@
|
|||
[get-language-details-panel (lambda () language-details-panel)]
|
||||
[get/set-settings (lambda x (apply real-get/set-settings x))]
|
||||
[position (car positions)]
|
||||
[number (car numbers)]
|
||||
[mixin (compose
|
||||
number-mixin
|
||||
(language-mixin language get-language-details-panel get/set-settings))]
|
||||
[item
|
||||
(send hier-list new-item
|
||||
(if second-number
|
||||
(compose second-number-mixin mixin)
|
||||
mixin))]
|
||||
[text (send item get-editor)]
|
||||
[delta (send language get-style-delta)])
|
||||
[number (car numbers)])
|
||||
|
||||
(set! construct-details
|
||||
(let ([old construct-details])
|
||||
|
|
@ -529,24 +575,40 @@
|
|||
[else
|
||||
(get/set-settings (send language default-settings))])))))
|
||||
|
||||
(send item set-number number)
|
||||
(when second-number
|
||||
(send item set-second-number second-number))
|
||||
(send text insert position)
|
||||
(when delta
|
||||
(cond
|
||||
[(list? delta)
|
||||
(for-each (λ (x)
|
||||
(send text change-style
|
||||
(car x)
|
||||
(cadr x)
|
||||
(caddr x)))
|
||||
delta)]
|
||||
[(is-a? delta style-delta%)
|
||||
(send text change-style
|
||||
(send language get-style-delta)
|
||||
0
|
||||
(send text last-position))])))]
|
||||
(cond
|
||||
[(equal? positions '("Module"))
|
||||
(set! module-language*language language)
|
||||
(set! module-language*get-language-details-panel get-language-details-panel)
|
||||
(set! module-language*get/set-settings get/set-settings)]
|
||||
[else
|
||||
(let* ([mixin (compose
|
||||
number-mixin
|
||||
(language-mixin language get-language-details-panel get/set-settings))]
|
||||
[item
|
||||
(send hier-list new-item
|
||||
(if second-number
|
||||
(compose second-number-mixin mixin)
|
||||
mixin))]
|
||||
[text (send item get-editor)]
|
||||
[delta (send language get-style-delta)])
|
||||
(send item set-number number)
|
||||
(when second-number
|
||||
(send item set-second-number second-number))
|
||||
(send text insert position)
|
||||
(when delta
|
||||
(cond
|
||||
[(list? delta)
|
||||
(for-each (λ (x)
|
||||
(send text change-style
|
||||
(car x)
|
||||
(cadr x)
|
||||
(caddr x)))
|
||||
delta)]
|
||||
[(is-a? delta style-delta%)
|
||||
(send text change-style
|
||||
(send language get-style-delta)
|
||||
0
|
||||
(send text last-position))])))]))]
|
||||
[else (let* ([position (car positions)]
|
||||
[number (car numbers)]
|
||||
[sub-ht/sub-hier-list
|
||||
|
|
@ -662,32 +724,39 @@
|
|||
;; and selects the current language
|
||||
(define (open-current-language)
|
||||
(when (and language-to-show settings-to-show)
|
||||
(let ([language-position (send language-to-show get-language-position)])
|
||||
(cond
|
||||
[(null? (cdr language-position))
|
||||
;; nothing to open here
|
||||
;; this should only be the module language
|
||||
(send (car (send languages-hier-list get-items)) select #t)
|
||||
(void)]
|
||||
[else
|
||||
(let loop ([hi languages-hier-list]
|
||||
|
||||
;; skip the first position, since it is flattened into the dialog
|
||||
[first-pos (cadr language-position)]
|
||||
[position (cddr language-position)])
|
||||
(let ([child
|
||||
;; know that this `car' is okay by construction of the dialog
|
||||
(car
|
||||
(filter (λ (x)
|
||||
(equal? (send (send x get-editor) get-text)
|
||||
first-pos))
|
||||
(send hi get-items)))])
|
||||
(cond
|
||||
[(null? position)
|
||||
(send child select #t)]
|
||||
[else
|
||||
(send child open)
|
||||
(loop child (car position) (cdr position))])))]))))
|
||||
(cond
|
||||
[(equal? language-to-show
|
||||
module-language*language)
|
||||
(send use-language-in-source-rb set-selection 0)
|
||||
(send use-chosen-language-rb set-selection #f)]
|
||||
[else
|
||||
(send use-chosen-language-rb set-selection 0)
|
||||
(send use-language-in-source-rb set-selection #f)
|
||||
(let ([language-position (send language-to-show get-language-position)])
|
||||
(cond
|
||||
[(null? (cdr language-position))
|
||||
;; nothing to open here
|
||||
(send (car (send languages-hier-list get-items)) select #t)
|
||||
(void)]
|
||||
[else
|
||||
(let loop ([hi languages-hier-list]
|
||||
|
||||
;; skip the first position, since it is flattened into the dialog
|
||||
[first-pos (cadr language-position)]
|
||||
[position (cddr language-position)])
|
||||
(let ([child
|
||||
;; know that this `car' is okay by construction of the dialog
|
||||
(car
|
||||
(filter (λ (x)
|
||||
(equal? (send (send x get-editor) get-text)
|
||||
first-pos))
|
||||
(send hi get-items)))])
|
||||
(cond
|
||||
[(null? position)
|
||||
(send child select #t)]
|
||||
[else
|
||||
(send child open)
|
||||
(loop child (car position) (cdr position))])))]))])))
|
||||
|
||||
;; docs-callback : -> void
|
||||
(define (docs-callback)
|
||||
|
|
@ -826,6 +895,34 @@
|
|||
(and get/set-selected-language-settings
|
||||
(get/set-selected-language-settings))))))
|
||||
|
||||
(define (add-discussion p)
|
||||
(let* ([t (new text:standard-style-list%)]
|
||||
[c (new editor-canvas%
|
||||
[stretchable-width #t]
|
||||
[horizontal-inset 0]
|
||||
[vertical-inset 0]
|
||||
[parent p]
|
||||
[style '(no-border auto-vscroll no-hscroll transparent)]
|
||||
[editor t])])
|
||||
(send c set-line-count 3)
|
||||
|
||||
(send t set-styles-sticky #f)
|
||||
(send t set-autowrap-bitmap #f)
|
||||
(let ([do-insert
|
||||
(λ (str style)
|
||||
(let ([before (send t last-position)])
|
||||
(send t insert str before before)
|
||||
(send t change-style style before (send t last-position))))])
|
||||
(let loop ([strs (regexp-split #rx"#lang" sc-lang-in-source-discussion)])
|
||||
(do-insert (car strs) (send (send t get-style-list) basic-style))
|
||||
(unless (null? (cdr strs))
|
||||
(do-insert "#lang" (send (send t get-style-list) find-named-style "standard"))
|
||||
(loop (cdr strs)))))
|
||||
(send t hide-caret #t)
|
||||
|
||||
(send t auto-wrap #t)
|
||||
(send t lock #t)))
|
||||
|
||||
(define panel-background-editor-canvas%
|
||||
(class editor-canvas%
|
||||
(inherit get-dc get-client-size)
|
||||
|
|
|
|||
|
|
@ -152,6 +152,11 @@
|
|||
(λ (x) (and (list? x)
|
||||
(andmap (λ (x) (or (path? x) (drscheme:frame:planet-spec? x)))
|
||||
x))))
|
||||
(preferences:set-default 'drscheme:install-plt-dialog
|
||||
'(#t "" "") ; url-selected?, url string, file string
|
||||
(λ (x) (and (list? x) (= 3 (length x))
|
||||
(boolean? (car x))
|
||||
(andmap string? (cdr x)))))
|
||||
|
||||
(preferences:set-un/marshall
|
||||
'drscheme:user-defined-keybindings
|
||||
|
|
|
|||
|
|
@ -1618,6 +1618,7 @@ TODO
|
|||
(reset-regions (list (list (last-position) (last-position))))
|
||||
(set-unread-start-point (last-position))
|
||||
(set-insertion-point (last-position))
|
||||
(set! indenting-limit (last-position))
|
||||
(set-allow-edits #f)
|
||||
(set! repl-header-end #f)
|
||||
(end-edit-sequence))
|
||||
|
|
@ -1653,6 +1654,12 @@ TODO
|
|||
(end-edit-sequence)
|
||||
(clear-undos))
|
||||
|
||||
(define indenting-limit 0)
|
||||
(define/override (get-limit n)
|
||||
(cond
|
||||
[(< n indenting-limit) 0]
|
||||
[else indenting-limit]))
|
||||
|
||||
;; avoid calling paragraph-start-position very often.
|
||||
(define repl-header-end #f)
|
||||
(define/private (get-repl-header-end)
|
||||
|
|
|
|||
|
|
@ -10,11 +10,15 @@
|
|||
(honu-* *)
|
||||
(honu-/ /)
|
||||
(honu-- -)
|
||||
(honu-? ?)
|
||||
(honu-: :)
|
||||
(honu-comma |,|)
|
||||
)
|
||||
#%datum
|
||||
true
|
||||
false
|
||||
display
|
||||
display2
|
||||
newline
|
||||
else
|
||||
(rename-out
|
||||
|
|
|
|||
|
|
@ -22,17 +22,18 @@
|
|||
;; macro for defining literal tokens that can be used in macros
|
||||
(define-syntax-rule (define-literal name ...)
|
||||
(begin
|
||||
(define-syntax name (lambda (stx)
|
||||
(raise-syntax-error 'name
|
||||
"this is a literal and cannot be used outside a macro")))
|
||||
...))
|
||||
(define-syntax name (lambda (stx)
|
||||
(raise-syntax-error 'name
|
||||
"this is a literal and cannot be used outside a macro")))
|
||||
...))
|
||||
|
||||
(define-literal honu-return)
|
||||
(define-literal semicolon)
|
||||
(define-literal honu-+ honu-* honu-/ honu-- honu-|| honu-%
|
||||
honu-= honu-+= honu--= honu-*= honu-/= honu-%=
|
||||
honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>=
|
||||
honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=)
|
||||
honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
|
||||
honu-? honu-: honu-comma)
|
||||
|
||||
;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx))
|
||||
|
||||
|
|
@ -43,9 +44,9 @@
|
|||
|
||||
|
||||
(define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!)
|
||||
(make-struct-type 'honu-trans #f 1 0 #f
|
||||
(list (list prop:honu-transformer #t))
|
||||
(current-inspector) 0))
|
||||
(make-struct-type 'honu-trans #f 1 0 #f
|
||||
(list (list prop:honu-transformer #t))
|
||||
(current-inspector) 0))
|
||||
|
||||
(define (make-honu-transformer proc)
|
||||
(unless (and (procedure? proc)
|
||||
|
|
@ -355,6 +356,7 @@
|
|||
x(2)
|
||||
|#
|
||||
|
||||
|
||||
(define (parse-block-one/2 stx context)
|
||||
(define (parse-one stx context)
|
||||
(define-syntax-class block
|
||||
|
|
@ -368,24 +370,29 @@ x(2)
|
|||
[pattern f])
|
||||
|
||||
(define-splicing-syntax-class call
|
||||
[pattern (~seq e:expr (#%parens arg:expression-1))
|
||||
#:with call #'(e arg.result)])
|
||||
#:literals (honu-comma)
|
||||
[pattern (~seq e:expr (#%parens (~seq arg:ternary (~optional honu-comma)) ...))
|
||||
#:with call #'(e arg.result ...)])
|
||||
(define-splicing-syntax-class expression-last
|
||||
[pattern (~seq call:call) #:with result #'call.call]
|
||||
[pattern (~seq x:number) #:with result #'x]
|
||||
)
|
||||
|
||||
(define-syntax-rule (define-infix-operator name next [operator reducer] ...)
|
||||
(define-splicing-syntax-class name
|
||||
#:literals (operator ...)
|
||||
[pattern (~seq (~var left next) operator (~var right name))
|
||||
#:with result (reducer #'left.result #'right.result)]
|
||||
...
|
||||
[pattern (~seq (~var exp next))
|
||||
#:with result #'exp.result]
|
||||
))
|
||||
(begin
|
||||
(define-syntax-class operator-class
|
||||
#:literals (operator ...)
|
||||
(pattern operator #:attr func reducer)
|
||||
...)
|
||||
(define-splicing-syntax-class name
|
||||
(pattern (~seq (~var left next)
|
||||
(~optional (~seq (~var op operator-class) (~var right name))))
|
||||
#:with result
|
||||
(cond [(attribute right)
|
||||
((attribute op.func) #'left.result #'right.result)]
|
||||
[else
|
||||
#'left.result])))))
|
||||
|
||||
;; TODO: maybe just have a precedence macro that creates all these constructs
|
||||
;; (infix-operators ([honu-* ...]
|
||||
;; [honu-- ...])
|
||||
;; ([honu-+ ...]
|
||||
|
|
@ -414,23 +421,6 @@ x(2)
|
|||
#'(begin
|
||||
result ...)))]))
|
||||
|
||||
#;
|
||||
(infix-operators expression-1 expression-last
|
||||
([honu-+ (syntax-lambda (left right)
|
||||
#'(+ left right))]
|
||||
[honu-- (syntax-lambda (left right)
|
||||
#'(- left right))])
|
||||
([honu-* (syntax-lambda (left right)
|
||||
#'(* left right))]
|
||||
[honu-/ (syntax-lambda (left right)
|
||||
#'(/ left right))]))
|
||||
|
||||
|
||||
(define-syntax-class expression-top
|
||||
[pattern (e:expression-1 semicolon . rest)
|
||||
#:with result #'e.result])
|
||||
|
||||
|
||||
;; infix operators in the appropriate precedence level
|
||||
;; things defined lower in the table have a higher precedence.
|
||||
;; the first set of operators is `expression-1'
|
||||
|
|
@ -462,10 +452,25 @@ x(2)
|
|||
[honu-% (sl (left right) #'(modulo left right))]
|
||||
[honu-/ (sl (left right) #'(/ left right))])))
|
||||
|
||||
(define-splicing-syntax-class ternary
|
||||
#:literals (honu-? honu-:)
|
||||
[pattern (~seq condition:expression-1 (~optional (~seq honu-? on-true:ternary
|
||||
honu-: on-false:ternary)))
|
||||
#:with result
|
||||
(cond [(attribute on-true)
|
||||
#'(if condition.result on-true.result on-false.result)]
|
||||
[else #'condition.result])])
|
||||
|
||||
(define-syntax-class expression-top
|
||||
#:literals (semicolon)
|
||||
[pattern (e:ternary semicolon . rest)
|
||||
#:with result #'e.result])
|
||||
|
||||
;; (printf "~a\n" (syntax-class-parse function stx))
|
||||
(syntax-parse stx
|
||||
[function:function (values #'function.result #'function.rest)]
|
||||
[expr:expression-top (values #'expr.result #'expr.rest)]
|
||||
#;
|
||||
[(x:number . rest) (values #'x #'rest)]
|
||||
))
|
||||
(cond
|
||||
|
|
@ -643,6 +648,9 @@ if (foo){
|
|||
(define-syntax (honu-top stx)
|
||||
(raise-syntax-error #f "interactive use is not yet supported"))
|
||||
|
||||
(define (display2 x y)
|
||||
(printf "~a ~a" x y))
|
||||
|
||||
(define-syntax (honu-unparsed-begin stx)
|
||||
;; (printf "honu unparsed begin: ~a\n" (syntax->datum stx))
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@
|
|||
(define (expand/show-predicate stx show?)
|
||||
(let-values ([(result deriv) (trace/result stx)])
|
||||
(when (exn? result) (raise result))
|
||||
(let-values ([(_steps _uses stx exn2)
|
||||
(let-values ([(_steps _defs _uses stx exn2)
|
||||
(parameterize ((macro-policy show?))
|
||||
(reductions+ deriv))])
|
||||
(when (exn? exn2) (raise exn2))
|
||||
|
|
|
|||
|
|
@ -93,13 +93,6 @@
|
|||
((if display-like? display write) (syntax-dummy-val obj) port)]
|
||||
[else
|
||||
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
|
||||
(define (pp-extend-style-table)
|
||||
(let* ([ids identifier-list]
|
||||
[syms (map (lambda (x) (hash-ref stx=>flat x)) ids)]
|
||||
[like-syms (map syntax-e ids)])
|
||||
(pretty-print-extend-style-table (pp-better-style-table)
|
||||
syms
|
||||
like-syms)))
|
||||
(define (pp-better-style-table)
|
||||
(pretty-print-extend-style-table (pretty-print-current-style-table)
|
||||
(map car extended-style-list)
|
||||
|
|
@ -107,7 +100,7 @@
|
|||
(parameterize
|
||||
([pretty-print-size-hook pp-size-hook]
|
||||
[pretty-print-print-hook pp-print-hook]
|
||||
[pretty-print-current-style-table (pp-extend-style-table)])
|
||||
[pretty-print-current-style-table (pp-better-style-table)])
|
||||
(pretty-print/defaults datum)))
|
||||
|
||||
(define (->show-function show)
|
||||
|
|
|
|||
|
|
@ -344,7 +344,7 @@ mz-manuals := (scribblings: "main/") ; generates main pages (next line)
|
|||
(notes: "COPYING.LIB" "COPYING-libscheme.txt")
|
||||
(doc: "doc-license.txt") ; needed (when docs are included)
|
||||
(doc+src: "reference/" "guide/" "quick/" "more/"
|
||||
"foreign/" "inside/" "futures/"
|
||||
"foreign/" "inside/" "futures/" "places/"
|
||||
"honu/")
|
||||
(doc: "*.{html|css|js|sxref}")
|
||||
(scribblings: "{{info|icons}.ss|*.png}" "compiled")
|
||||
|
|
|
|||
|
|
@ -117,7 +117,7 @@
|
|||
(unless (and (integer? i) (exact? i) (not (negative? i)))
|
||||
(raise-type-error (who->name who)
|
||||
(if false-ok?
|
||||
"non-negative exact integeror #f"
|
||||
"non-negative exact integer or #f"
|
||||
"non-negative exact integer" )
|
||||
i))))
|
||||
|
||||
|
|
|
|||
|
|
@ -264,40 +264,47 @@
|
|||
(check-container-parent cwho parent)
|
||||
(check-callback cwho callback)
|
||||
(check-orientation cwho style)
|
||||
(check-non-negative-integer cwho selection)))
|
||||
(check-non-negative-integer/false cwho selection)))
|
||||
(private-field
|
||||
[wx #f])
|
||||
(private
|
||||
[check-button
|
||||
(lambda (method n)
|
||||
(check-non-negative-integer `(method radio-box% ,method) n)
|
||||
(unless (< n (length chcs))
|
||||
(raise-mismatch-error (who->name `(method radio-box% ,method)) "no such button: " n)))])
|
||||
(lambda (method n false-ok?)
|
||||
((if false-ok?
|
||||
check-non-negative-integer/false
|
||||
check-non-negative-integer)
|
||||
`(method radio-box% ,method) n)
|
||||
(when n
|
||||
(unless (< n (length chcs))
|
||||
(raise-mismatch-error (who->name `(method radio-box% ,method)) "no such button: " n))))])
|
||||
(override
|
||||
[enable (entry-point
|
||||
(case-lambda
|
||||
[(on?) (send wx enable on?)]
|
||||
[(which on?) (check-button 'enable which)
|
||||
[(which on?) (check-button 'enable which #f)
|
||||
(send wx enable which on?)]))]
|
||||
[is-enabled? (entry-point
|
||||
(case-lambda
|
||||
[() (send wx is-enabled?)]
|
||||
[(which) (check-button 'is-enabled? which)
|
||||
[(which) (check-button 'is-enabled? which #f)
|
||||
(send wx is-enabled? which)]))])
|
||||
(public
|
||||
[get-number (lambda () (length chcs))]
|
||||
[get-item-label (lambda (n)
|
||||
(check-button 'get-item-label n)
|
||||
(check-button 'get-item-label n #f)
|
||||
(list-ref chcs n))]
|
||||
[get-item-plain-label (lambda (n)
|
||||
(check-button 'get-item-plain-label n)
|
||||
(check-button 'get-item-plain-label n #f)
|
||||
(wx:label->plain-label (list-ref chcs n)))]
|
||||
|
||||
[get-selection (entry-point (lambda () (send wx get-selection)))]
|
||||
[get-selection (entry-point (lambda () (let ([v (send wx get-selection)])
|
||||
(if (equal? v -1)
|
||||
#f
|
||||
v))))]
|
||||
[set-selection (entry-point
|
||||
(lambda (v)
|
||||
(check-button 'set-selection v)
|
||||
(send wx set-selection v)))])
|
||||
(check-button 'set-selection v #t)
|
||||
(send wx set-selection (or v -1))))])
|
||||
(sequence
|
||||
(as-entry
|
||||
(lambda ()
|
||||
|
|
@ -317,7 +324,7 @@
|
|||
(length choices))
|
||||
selection))))
|
||||
label parent callback #f)))
|
||||
(when (positive? selection)
|
||||
(when (or (not selection) (positive? selection))
|
||||
(set-selection selection)))))
|
||||
|
||||
(define slider%
|
||||
|
|
|
|||
|
|
@ -14,9 +14,6 @@
|
|||
|
||||
(define (exotic-choice? [random random]) (= 0 (random 5)))
|
||||
(define (use-lang-literal? [random random]) (= 0 (random 20)))
|
||||
(define (preferred-production? attempt [random random])
|
||||
(and (>= attempt preferred-production-threshold)
|
||||
(zero? (random 2))))
|
||||
|
||||
(define default-check-attempts 1000)
|
||||
|
||||
|
|
@ -57,27 +54,8 @@
|
|||
(define (pick-string lang-lits attempt [random random])
|
||||
(random-string lang-lits (random-natural 1/5 random) attempt random))
|
||||
|
||||
(define (pick-nt name cross? lang attempt pref-prods
|
||||
[random random]
|
||||
[pref-prod? preferred-production?])
|
||||
(let ([prods (nt-rhs (nt-by-name lang name cross?))])
|
||||
(cond [(and pref-prods (pref-prod? attempt random))
|
||||
(hash-ref
|
||||
((if cross? pref-prods-cross pref-prods-non-cross)
|
||||
pref-prods)
|
||||
name)]
|
||||
[else prods])))
|
||||
|
||||
(define-struct pref-prods (cross non-cross))
|
||||
|
||||
(define (pick-preferred-productions lang)
|
||||
(let ([pick (λ (sel)
|
||||
(for/hash ([nt (sel lang)])
|
||||
(values (nt-name nt)
|
||||
(list (pick-from-list (nt-rhs nt))))))])
|
||||
(make-pref-prods
|
||||
(pick compiled-lang-cclang)
|
||||
(pick compiled-lang-lang))))
|
||||
(define (pick-nts name cross? lang attempt)
|
||||
(nt-rhs (nt-by-name lang name cross?)))
|
||||
|
||||
(define (pick-from-list l [random random]) (list-ref l (random (length l))))
|
||||
|
||||
|
|
@ -118,9 +96,6 @@
|
|||
(define proportion-at-size 1/10)
|
||||
(define post-threshold-incr 50)
|
||||
|
||||
(define preferred-production-threshold
|
||||
(+ retry-threshold 2000))
|
||||
|
||||
;; Determines the parameter p for which random-natural's expected value is E
|
||||
(define (expected-value->p E)
|
||||
;; E = 0 => p = 1, which breaks random-natural
|
||||
|
|
@ -177,11 +152,11 @@
|
|||
who what attempts (if (= attempts 1) "" "s"))])
|
||||
(raise (make-exn:fail:redex:generation-failure str (current-continuation-marks)))))
|
||||
|
||||
(define (generate lang decisions@ user-gen retries what)
|
||||
(define (generate lang decisions@ what)
|
||||
(define-values/invoke-unit decisions@
|
||||
(import) (export decisions^))
|
||||
|
||||
(define ((generate-nt lang base-cases generate pref-prods)
|
||||
(define ((generate-nt lang base-cases generate retries)
|
||||
name cross? size attempt in-hole env)
|
||||
(let*-values
|
||||
([(term _)
|
||||
|
|
@ -193,10 +168,10 @@
|
|||
(min-prods (nt-by-name lang name cross?)
|
||||
((if cross? base-cases-cross base-cases-non-cross)
|
||||
base-cases))
|
||||
((next-non-terminal-decision) name cross? lang attempt pref-prods)))])
|
||||
((next-non-terminal-decision) name cross? lang attempt)))])
|
||||
(generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs))))
|
||||
(λ (_ env) (mismatches-satisfied? env))
|
||||
size attempt)])
|
||||
size attempt retries)])
|
||||
term))
|
||||
|
||||
(define (generate-sequence ellipsis generate env length)
|
||||
|
|
@ -222,18 +197,18 @@
|
|||
(values (cons term terms) (cons env envs)))))])
|
||||
(values seq (merge-environments envs))))
|
||||
|
||||
(define (generate/pred name gen pred init-sz init-att)
|
||||
(define (generate/pred name gen pred init-sz init-att retries)
|
||||
(let ([pre-threshold-incr
|
||||
(ceiling
|
||||
(/ (- retry-threshold init-att)
|
||||
(* proportion-before-threshold retries)))]
|
||||
(* proportion-before-threshold (add1 retries))))]
|
||||
[incr-size?
|
||||
(λ (remain)
|
||||
(zero?
|
||||
(modulo (sub1 remain)
|
||||
(ceiling (* proportion-at-size
|
||||
retries)))))])
|
||||
(let retry ([remaining retries]
|
||||
(let retry ([remaining (add1 retries)]
|
||||
[size init-sz]
|
||||
[attempt init-att])
|
||||
(if (zero? remaining)
|
||||
|
|
@ -279,120 +254,109 @@
|
|||
(cons (make-bind (binder-name key) val) bindings)
|
||||
bindings))))
|
||||
|
||||
(define (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat)
|
||||
(define recur (curry generate-pat lang sexp pref-prods user-gen user-acc size attempt))
|
||||
(define (generate-pat lang sexp retries size attempt env in-hole pat)
|
||||
(define recur (curry generate-pat lang sexp retries size attempt))
|
||||
(define recur/pat (recur env in-hole))
|
||||
(define ((recur/pat/size-attempt pat) size attempt)
|
||||
(generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat))
|
||||
(generate-pat lang sexp retries size attempt env in-hole pat))
|
||||
|
||||
(define clang (rg-lang-clang lang))
|
||||
(define gen-nt
|
||||
(generate-nt
|
||||
clang
|
||||
(rg-lang-base-cases lang)
|
||||
(curry generate-pat lang sexp pref-prods user-gen user-acc)
|
||||
pref-prods))
|
||||
(curry generate-pat lang sexp retries)
|
||||
retries))
|
||||
|
||||
(define (default-gen user-acc)
|
||||
(match pat
|
||||
[`number (values ((next-number-decision) attempt) env)]
|
||||
[`natural (values ((next-natural-decision) attempt) env)]
|
||||
[`integer (values ((next-integer-decision) attempt) env)]
|
||||
[`real (values ((next-real-decision) attempt) env)]
|
||||
[`(variable-except ,vars ...)
|
||||
(generate/pred 'variable
|
||||
(recur/pat/size-attempt 'variable)
|
||||
(λ (var _) (not (memq var vars)))
|
||||
size attempt)]
|
||||
[`variable
|
||||
(values ((next-variable-decision) (rg-lang-lits lang) attempt)
|
||||
env)]
|
||||
[`variable-not-otherwise-mentioned
|
||||
(generate/pred 'variable
|
||||
(recur/pat/size-attempt 'variable)
|
||||
(λ (var _) (not (memq var (compiled-lang-literals clang))))
|
||||
size attempt)]
|
||||
[`(variable-prefix ,prefix)
|
||||
(define (symbol-append prefix suffix)
|
||||
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
|
||||
(let-values ([(term env) (recur/pat 'variable)])
|
||||
(values (symbol-append prefix term) env))]
|
||||
[`string
|
||||
(values ((next-string-decision) (rg-lang-lits lang) attempt)
|
||||
env)]
|
||||
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
|
||||
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
|
||||
(recur/pat/size-attempt pat)
|
||||
(λ (_ env) (condition (bindings env)))
|
||||
size attempt)]
|
||||
[`(name ,(? symbol? id) ,p)
|
||||
(let-values ([(term env) (recur/pat p)])
|
||||
(values term (hash-set env (make-binder id) term)))]
|
||||
[`hole (values in-hole env)]
|
||||
[`(in-hole ,context ,contractum)
|
||||
(let-values ([(term env) (recur/pat contractum)])
|
||||
(recur env term context))]
|
||||
[`(hide-hole ,pattern) (recur env the-hole pattern)]
|
||||
[`any
|
||||
(let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
|
||||
; Don't use preferred productions for the sexp language.
|
||||
[(pref-prods) (if (eq? new-lang lang) pref-prods #f)]
|
||||
[(term _) (generate-pat new-lang
|
||||
sexp
|
||||
pref-prods
|
||||
user-gen
|
||||
user-acc
|
||||
size
|
||||
attempt
|
||||
empty-env
|
||||
the-hole
|
||||
nt)])
|
||||
(values term env))]
|
||||
[(? (is-nt? clang))
|
||||
(values (gen-nt pat #f size attempt in-hole env) env)]
|
||||
[(struct binder ((or (? (is-nt? clang) nt)
|
||||
(app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))
|
||||
(generate/prior pat env (λ () (recur/pat nt)))]
|
||||
[(struct binder ((or (? built-in? b)
|
||||
(app (symbol-match named-nt-rx) (? built-in? b)))))
|
||||
(generate/prior pat env (λ () (recur/pat b)))]
|
||||
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
|
||||
(? symbol? (? (is-nt? clang) nt)))))
|
||||
(let-values ([(term _) (recur/pat nt)])
|
||||
(values term (hash-set env pat term)))]
|
||||
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
|
||||
(? symbol? (? built-in? b)))))
|
||||
(let-values ([(term _) (recur/pat b)])
|
||||
(values term (hash-set env pat term)))]
|
||||
[`(cross ,(? symbol? cross-nt))
|
||||
(values (gen-nt cross-nt #t size attempt in-hole env) env)]
|
||||
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)]
|
||||
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
|
||||
(let*-values ([(length) (let ([prior (hash-ref env class #f)])
|
||||
(if prior prior ((next-sequence-decision) attempt)))]
|
||||
[(seq env) (generate-sequence ellipsis recur env length)]
|
||||
[(rest env) (recur (hash-set (hash-set env class length) name length)
|
||||
in-hole rest)])
|
||||
(values (append seq rest) env))]
|
||||
[(list-rest pat rest)
|
||||
(let*-values
|
||||
([(pat-term env) (recur/pat pat)]
|
||||
[(rest-term env) (recur env in-hole rest)])
|
||||
(values (cons pat-term rest-term) env))]
|
||||
[else
|
||||
(error what "unknown pattern ~s\n" pat)]))
|
||||
|
||||
(user-gen
|
||||
pat size in-hole user-acc env attempt
|
||||
(λ (pat #:size [size size] #:contractum [in-hole in-hole] #:acc [user-acc user-acc] #:env [env env])
|
||||
(generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat))
|
||||
default-gen))
|
||||
(match pat
|
||||
[`number (values ((next-number-decision) attempt) env)]
|
||||
[`natural (values ((next-natural-decision) attempt) env)]
|
||||
[`integer (values ((next-integer-decision) attempt) env)]
|
||||
[`real (values ((next-real-decision) attempt) env)]
|
||||
[`(variable-except ,vars ...)
|
||||
(generate/pred 'variable
|
||||
(recur/pat/size-attempt 'variable)
|
||||
(λ (var _) (not (memq var vars)))
|
||||
size attempt retries)]
|
||||
[`variable
|
||||
(values ((next-variable-decision) (rg-lang-lits lang) attempt)
|
||||
env)]
|
||||
[`variable-not-otherwise-mentioned
|
||||
(generate/pred 'variable
|
||||
(recur/pat/size-attempt 'variable)
|
||||
(λ (var _) (not (memq var (compiled-lang-literals clang))))
|
||||
size attempt retries)]
|
||||
[`(variable-prefix ,prefix)
|
||||
(define (symbol-append prefix suffix)
|
||||
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
|
||||
(let-values ([(term env) (recur/pat 'variable)])
|
||||
(values (symbol-append prefix term) env))]
|
||||
[`string
|
||||
(values ((next-string-decision) (rg-lang-lits lang) attempt)
|
||||
env)]
|
||||
[`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc)
|
||||
(generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc)
|
||||
(recur/pat/size-attempt pat)
|
||||
(λ (_ env) (condition (bindings env)))
|
||||
size attempt retries)]
|
||||
[`(name ,(? symbol? id) ,p)
|
||||
(let-values ([(term env) (recur/pat p)])
|
||||
(values term (hash-set env (make-binder id) term)))]
|
||||
[`hole (values in-hole env)]
|
||||
[`(in-hole ,context ,contractum)
|
||||
(let-values ([(term env) (recur/pat contractum)])
|
||||
(recur env term context))]
|
||||
[`(hide-hole ,pattern) (recur env the-hole pattern)]
|
||||
[`any
|
||||
(let*-values ([(new-lang nt) ((next-any-decision) lang sexp)]
|
||||
[(term _) (generate-pat new-lang
|
||||
sexp
|
||||
retries
|
||||
size
|
||||
attempt
|
||||
empty-env
|
||||
the-hole
|
||||
nt)])
|
||||
(values term env))]
|
||||
[(? (is-nt? clang))
|
||||
(values (gen-nt pat #f size attempt in-hole env) env)]
|
||||
[(struct binder ((or (? (is-nt? clang) nt)
|
||||
(app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))
|
||||
(generate/prior pat env (λ () (recur/pat nt)))]
|
||||
[(struct binder ((or (? built-in? b)
|
||||
(app (symbol-match named-nt-rx) (? built-in? b)))))
|
||||
(generate/prior pat env (λ () (recur/pat b)))]
|
||||
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
|
||||
(? symbol? (? (is-nt? clang) nt)))))
|
||||
(let-values ([(term _) (recur/pat nt)])
|
||||
(values term (hash-set env pat term)))]
|
||||
[(struct mismatch (name (app (symbol-match mismatch-nt-rx)
|
||||
(? symbol? (? built-in? b)))))
|
||||
(let-values ([(term _) (recur/pat b)])
|
||||
(values term (hash-set env pat term)))]
|
||||
[`(cross ,(? symbol? cross-nt))
|
||||
(values (gen-nt cross-nt #t size attempt in-hole env) env)]
|
||||
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)]
|
||||
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
|
||||
(let*-values ([(length) (let ([prior (hash-ref env class #f)])
|
||||
(if prior prior ((next-sequence-decision) attempt)))]
|
||||
[(seq env) (generate-sequence ellipsis recur env length)]
|
||||
[(rest env) (recur (hash-set (hash-set env class length) name length)
|
||||
in-hole rest)])
|
||||
(values (append seq rest) env))]
|
||||
[(list-rest pat rest)
|
||||
(let*-values
|
||||
([(pat-term env) (recur/pat pat)]
|
||||
[(rest-term env) (recur env in-hole rest)])
|
||||
(values (cons pat-term rest-term) env))]
|
||||
[else
|
||||
(error what "unknown pattern ~s\n" pat)]))
|
||||
|
||||
(let ([rg-lang (prepare-lang lang)]
|
||||
[rg-sexp (prepare-lang sexp)])
|
||||
(λ (pat)
|
||||
(let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))])
|
||||
(λ (size attempt)
|
||||
(λ (size attempt retries)
|
||||
(let-values ([(term env)
|
||||
(generate/pred
|
||||
pat
|
||||
|
|
@ -400,16 +364,14 @@
|
|||
(generate-pat
|
||||
rg-lang
|
||||
rg-sexp
|
||||
((next-pref-prods-decision) (rg-lang-clang rg-lang))
|
||||
user-gen
|
||||
#f
|
||||
retries
|
||||
size
|
||||
attempt
|
||||
empty-env
|
||||
the-hole
|
||||
parsed))
|
||||
(λ (_ env) (mismatches-satisfied? env))
|
||||
size attempt)])
|
||||
size attempt retries)])
|
||||
(values term (bindings env))))))))
|
||||
|
||||
(define-struct base-cases (cross non-cross))
|
||||
|
|
@ -681,36 +643,35 @@
|
|||
x
|
||||
(raise-type-error 'redex-check "reduction-relation" x)))
|
||||
|
||||
(define (defer-all pat size in-hole acc env att recur defer)
|
||||
(defer acc))
|
||||
|
||||
(define-for-syntax (term-generator lang pat decisions@ custom retries what)
|
||||
(define-for-syntax (term-generator lang pat decisions@ what)
|
||||
(with-syntax ([pattern
|
||||
(rewrite-side-conditions/check-errs
|
||||
(language-id-nts lang what)
|
||||
what #t pat)])
|
||||
#`((generate #,lang #,decisions@ #,custom #,retries '#,what) `pattern)))
|
||||
#`((generate #,lang #,decisions@ '#,what) `pattern)))
|
||||
|
||||
(define-syntax (generate-term stx)
|
||||
(syntax-case stx ()
|
||||
[(_ lang pat size . kw-args)
|
||||
(with-syntax ([(attempt retries custom)
|
||||
(parse-kw-args `((#:attempt . 1)
|
||||
(#:retries . ,#'default-retries)
|
||||
(#:custom . ,#'defer-all))
|
||||
[(name lang pat size . kw-args)
|
||||
(with-syntax ([(attempt retries)
|
||||
(parse-kw-args `((#:attempt-num . 1)
|
||||
(#:retries . ,#'default-retries))
|
||||
(syntax kw-args)
|
||||
stx)])
|
||||
(with-syntax ([generate (term-generator #'lang
|
||||
#'pat
|
||||
#'(generation-decisions)
|
||||
#'custom
|
||||
#'retries
|
||||
'generate-term)])
|
||||
(syntax/loc stx
|
||||
(let-values ([(term _) (generate size attempt)])
|
||||
term))))]
|
||||
[(_ lang pat size)
|
||||
(syntax/loc stx (generate-term lang pat size #:attempt 1))]))
|
||||
(syntax/loc stx
|
||||
((generate-term lang pat) size #:attempt-num attempt #:retries retries)))]
|
||||
[(name lang pat)
|
||||
(with-syntax ([make-gen (term-generator #'lang
|
||||
#'pat
|
||||
#'(generation-decisions)
|
||||
(syntax-e #'name))])
|
||||
(syntax/loc stx
|
||||
(let ([generate make-gen])
|
||||
(λ (size #:attempt-num [attempt-num 1] #:retries [retries default-retries])
|
||||
(let ([att (assert-nat 'name attempt-num)]
|
||||
[ret (assert-nat 'name retries)])
|
||||
(let-values ([(term _) (generate size att ret)])
|
||||
term))))))]))
|
||||
|
||||
(define-for-syntax (show-message stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -734,12 +695,12 @@
|
|||
(let-values ([(names names/ellipses)
|
||||
(extract-names (language-id-nts #'lang 'redex-check)
|
||||
'redex-check #t #'pat)]
|
||||
[(attempts-stx source-stx retries-stx custom-stx)
|
||||
[(attempts-stx source-stx retries-stx print?-stx)
|
||||
(apply values
|
||||
(parse-kw-args `((#:attempts . ,#'default-check-attempts)
|
||||
(#:source . #f)
|
||||
(#:retries . ,#'default-retries)
|
||||
(#:custom . ,#'defer-all))
|
||||
(#:print? . #t))
|
||||
(syntax kw-args)
|
||||
stx))])
|
||||
(with-syntax ([(name ...) names]
|
||||
|
|
@ -752,17 +713,7 @@
|
|||
(quasisyntax/loc stx
|
||||
(let ([att (assert-nat 'redex-check #,attempts-stx)]
|
||||
[ret (assert-nat 'redex-check #,retries-stx)]
|
||||
[custom (contract
|
||||
(-> any/c natural-number/c any/c any/c hash? natural-number/c
|
||||
(->* (any/c)
|
||||
(#:size natural-number/c
|
||||
#:contractum any/c
|
||||
#:acc any/c
|
||||
#:env hash?)
|
||||
(values any/c hash?))
|
||||
(-> any/c (values any/c hash?))
|
||||
(values any/c hash?))
|
||||
#,custom-stx '+ '-)])
|
||||
[print? #,print?-stx])
|
||||
(unsyntax
|
||||
(if source-stx
|
||||
#`(let-values ([(metafunc/red-rel num-cases)
|
||||
|
|
@ -776,27 +727,32 @@
|
|||
metafunc/red-rel
|
||||
property
|
||||
random-decisions@
|
||||
custom
|
||||
(max 1 (floor (/ att num-cases)))
|
||||
ret
|
||||
'redex-check
|
||||
show
|
||||
(and print? show)
|
||||
(test-match lang pat)
|
||||
(λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat))))
|
||||
#`(check-prop
|
||||
#,(term-generator #'lang #'pat #'random-decisions@ #'custom #'ret 'redex-check)
|
||||
property att show)))
|
||||
(void))))))]))
|
||||
#,(term-generator #'lang #'pat #'random-decisions@ 'redex-check)
|
||||
property att ret (and print? show)))))))))]))
|
||||
|
||||
(define (format-attempts a)
|
||||
(format "~a attempt~a" a (if (= 1 a) "" "s")))
|
||||
|
||||
(define (check-prop generator property attempts show)
|
||||
(when (check generator property attempts show)
|
||||
(show (format "no counterexamples in ~a\n"
|
||||
(format-attempts attempts)))))
|
||||
(define (check-prop generator property attempts retries show)
|
||||
(let ([c (check generator property attempts retries show)])
|
||||
(if (counterexample? c)
|
||||
(unless show c) ; check printed it
|
||||
(if show
|
||||
(show (format "no counterexamples in ~a\n"
|
||||
(format-attempts attempts)))
|
||||
#t))))
|
||||
|
||||
(define (check generator property attempts show
|
||||
(define-struct (exn:fail:redex:test exn:fail:redex) (source term))
|
||||
(define-struct counterexample (term))
|
||||
|
||||
(define (check generator property attempts retries show
|
||||
#:source [source #f]
|
||||
#:match [match #f]
|
||||
#:match-fail [match-fail #f])
|
||||
|
|
@ -804,14 +760,21 @@
|
|||
(if (zero? remaining)
|
||||
#t
|
||||
(let ([attempt (add1 (- attempts remaining))])
|
||||
(let-values ([(term bindings) (generator (attempt->size attempt) attempt)])
|
||||
(let-values ([(term bindings) (generator (attempt->size attempt) attempt retries)])
|
||||
(if (andmap (λ (bindings)
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(λ (exn)
|
||||
(show
|
||||
(format "checking ~s raises an exception\n" term))
|
||||
(raise exn))])
|
||||
(when show
|
||||
(show (format "checking ~s raises an exception\n" term)))
|
||||
(raise
|
||||
(if show
|
||||
exn
|
||||
(make-exn:fail:redex:test
|
||||
(format "checking ~s raises an exception:\n~a" term (exn-message exn))
|
||||
(current-continuation-marks)
|
||||
exn
|
||||
term))))])
|
||||
(property term bindings)))
|
||||
(cond [(and match match-fail (match term))
|
||||
=> (curry map (compose make-bindings match-bindings))]
|
||||
|
|
@ -819,22 +782,22 @@
|
|||
[else (list bindings)]))
|
||||
(loop (sub1 remaining))
|
||||
(begin
|
||||
(show
|
||||
(format "counterexample found after ~a~a:\n"
|
||||
(format-attempts attempt)
|
||||
(if source (format " with ~a" source) "")))
|
||||
(pretty-print term (current-output-port))
|
||||
#f)))))))
|
||||
(when show
|
||||
(show
|
||||
(format "counterexample found after ~a~a:\n"
|
||||
(format-attempts attempt)
|
||||
(if source (format " with ~a" source) "")))
|
||||
(pretty-print term (current-output-port)))
|
||||
(make-counterexample term))))))))
|
||||
|
||||
(define-syntax (check-metafunction-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name . kw-args)
|
||||
(identifier? #'name)
|
||||
(with-syntax ([m (metafunc/err #'name stx)]
|
||||
[(attempts retries custom)
|
||||
[(attempts retries)
|
||||
(parse-kw-args `((#:attempts . ,#'default-check-attempts)
|
||||
(#:retries . ,#'default-retries)
|
||||
(#:custom . ,#'defer-all))
|
||||
(#:retries . ,#'default-retries))
|
||||
(syntax kw-args)
|
||||
stx)]
|
||||
[show (show-message stx)])
|
||||
|
|
@ -844,18 +807,19 @@
|
|||
[decisions@ (generation-decisions)]
|
||||
[att (assert-nat 'check-metafunction-contract attempts)])
|
||||
(check-prop
|
||||
((generate lang decisions@ custom retries 'check-metafunction-contract)
|
||||
((generate lang decisions@ 'check-metafunction-contract)
|
||||
(if dom dom '(any (... ...))))
|
||||
(λ (t _)
|
||||
(with-handlers ([exn:fail:redex? (λ (_) #f)])
|
||||
(begin (term (name ,@t)) #t)))
|
||||
att
|
||||
retries
|
||||
show))))]))
|
||||
|
||||
(define (check-lhs-pats lang mf/rr prop decisions@ custom attempts retries what show
|
||||
[match #f]
|
||||
[match-fail #f])
|
||||
(let ([lang-gen (generate lang decisions@ custom retries what)])
|
||||
(define (check-lhs-pats lang mf/rr prop decisions@ attempts retries what show
|
||||
[match #f]
|
||||
[match-fail #f])
|
||||
(let ([lang-gen (generate lang decisions@ what)])
|
||||
(let-values ([(pats srcs)
|
||||
(cond [(metafunc-proc? mf/rr)
|
||||
(values (map metafunc-case-lhs-pat (metafunc-proc-cases mf/rr))
|
||||
|
|
@ -863,47 +827,53 @@
|
|||
[(reduction-relation? mf/rr)
|
||||
(values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr))
|
||||
(reduction-relation-srcs mf/rr))])])
|
||||
(when (for/and ([pat pats] [src srcs])
|
||||
(with-handlers ([exn:fail:redex:generation-failure?
|
||||
; Produce an error message that blames the LHS as a whole.
|
||||
(λ (_)
|
||||
(raise-gen-fail what (format "LHS of ~a" src) retries))])
|
||||
(check
|
||||
(lang-gen pat)
|
||||
prop
|
||||
attempts
|
||||
show
|
||||
#:source src
|
||||
#:match match
|
||||
#:match-fail match-fail)))
|
||||
(show
|
||||
(format "no counterexamples in ~a (with each clause)\n"
|
||||
(format-attempts attempts)))))))
|
||||
(let loop ([pats pats] [srcs srcs])
|
||||
(if (and (null? pats) (null? srcs))
|
||||
(if show
|
||||
(show
|
||||
(format "no counterexamples in ~a (with each clause)\n"
|
||||
(format-attempts attempts)))
|
||||
#t)
|
||||
(let ([c (with-handlers ([exn:fail:redex:generation-failure?
|
||||
; Produce an error message that blames the LHS as a whole.
|
||||
(λ (_)
|
||||
(raise-gen-fail what (format "LHS of ~a" (car srcs)) retries))])
|
||||
(check
|
||||
(lang-gen (car pats))
|
||||
prop
|
||||
attempts
|
||||
retries
|
||||
show
|
||||
#:source (car srcs)
|
||||
#:match match
|
||||
#:match-fail match-fail))])
|
||||
(if (counterexample? c)
|
||||
(unless show c)
|
||||
(loop (cdr pats) (cdr srcs)))))))))
|
||||
|
||||
(define-syntax (check-metafunction stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name property . kw-args)
|
||||
(with-syntax ([m (metafunc/err #'name stx)]
|
||||
[(attempts retries custom)
|
||||
[(attempts retries print?)
|
||||
(parse-kw-args `((#:attempts . , #'default-check-attempts)
|
||||
(#:retries . ,#'default-retries)
|
||||
(#:custm . ,#'defer-all))
|
||||
(#:print? . #t))
|
||||
(syntax kw-args)
|
||||
stx)]
|
||||
[show (show-message stx)])
|
||||
(syntax/loc stx
|
||||
(let ([att (assert-nat 'check-metafunction attempts)]
|
||||
[ret (assert-nat 'check-metafunction retries)])
|
||||
(check-lhs-pats
|
||||
(metafunc-proc-lang m)
|
||||
m
|
||||
(λ (term _) (property term))
|
||||
(generation-decisions)
|
||||
custom
|
||||
att
|
||||
ret
|
||||
'check-metafunction
|
||||
show))))]))
|
||||
stx)])
|
||||
(with-syntax ([show (show-message stx)])
|
||||
(syntax/loc stx
|
||||
(let ([att (assert-nat 'check-metafunction attempts)]
|
||||
[ret (assert-nat 'check-metafunction retries)])
|
||||
(check-lhs-pats
|
||||
(metafunc-proc-lang m)
|
||||
m
|
||||
(λ (term _) (property term))
|
||||
(generation-decisions)
|
||||
att
|
||||
ret
|
||||
'check-metafunction
|
||||
(and print? show))))))]))
|
||||
|
||||
(define (reduction-relation-srcs r)
|
||||
(map (λ (proc) (or (rewrite-proc-name proc)
|
||||
|
|
@ -917,11 +887,11 @@
|
|||
(define-syntax (check-reduction-relation stx)
|
||||
(syntax-case stx ()
|
||||
[(_ relation property . kw-args)
|
||||
(with-syntax ([(attempts retries decisions@ custom)
|
||||
(with-syntax ([(attempts retries decisions@ print?)
|
||||
(parse-kw-args `((#:attempts . , #'default-check-attempts)
|
||||
(#:retries . ,#'default-retries)
|
||||
(#:decisions . ,#'random-decisions@)
|
||||
(#:custom . ,#'defer-all))
|
||||
(#:print? . #t))
|
||||
(syntax kw-args)
|
||||
stx)]
|
||||
[show (show-message stx)])
|
||||
|
|
@ -934,11 +904,10 @@
|
|||
rel
|
||||
(λ (term _) (property term))
|
||||
decisions@
|
||||
custom
|
||||
attempts
|
||||
retries
|
||||
'check-reduction-relation
|
||||
show))))]))
|
||||
(and print? show)))))]))
|
||||
|
||||
(define-signature decisions^
|
||||
(next-variable-decision
|
||||
|
|
@ -949,8 +918,7 @@
|
|||
next-non-terminal-decision
|
||||
next-sequence-decision
|
||||
next-any-decision
|
||||
next-string-decision
|
||||
next-pref-prods-decision))
|
||||
next-string-decision))
|
||||
|
||||
(define random-decisions@
|
||||
(unit (import) (export decisions^)
|
||||
|
|
@ -959,11 +927,10 @@
|
|||
(define (next-natural-decision) pick-natural)
|
||||
(define (next-integer-decision) pick-integer)
|
||||
(define (next-real-decision) pick-real)
|
||||
(define (next-non-terminal-decision) pick-nt)
|
||||
(define (next-non-terminal-decision) pick-nts)
|
||||
(define (next-sequence-decision) pick-sequence-length)
|
||||
(define (next-any-decision) pick-any)
|
||||
(define (next-string-decision) pick-string)
|
||||
(define (next-pref-prods-decision) pick-preferred-productions)))
|
||||
(define (next-string-decision) pick-string)))
|
||||
|
||||
(define generation-decisions (make-parameter random-decisions@))
|
||||
|
||||
|
|
@ -979,18 +946,17 @@
|
|||
(struct-out class)
|
||||
(struct-out binder)
|
||||
(struct-out base-cases)
|
||||
(struct-out pref-prods))
|
||||
(struct-out counterexample)
|
||||
(struct-out exn:fail:redex:test))
|
||||
|
||||
(provide pick-from-list pick-sequence-length
|
||||
pick-char pick-var pick-string
|
||||
pick-nt pick-any pick-preferred-productions
|
||||
(provide pick-from-list pick-sequence-length pick-nts
|
||||
pick-char pick-var pick-string pick-any
|
||||
pick-number pick-natural pick-integer pick-real
|
||||
parse-pattern unparse-pattern
|
||||
parse-language prepare-lang
|
||||
class-reassignments reassign-classes
|
||||
default-retries proportion-at-size
|
||||
preferred-production-threshold retry-threshold
|
||||
proportion-before-threshold post-threshold-incr
|
||||
retry-threshold proportion-before-threshold post-threshold-incr
|
||||
is-nt? nt-by-name min-prods
|
||||
generation-decisions decisions^
|
||||
random-string
|
||||
|
|
|
|||
|
|
@ -1127,30 +1127,37 @@ metafunctions or unnamed reduction-relation cases) to application counts.}
|
|||
(values (covered-cases equals-coverage)
|
||||
(covered-cases plus-coverage))))]
|
||||
|
||||
@defform/subs[(generate-term language @#,ttpattern size-exp kw-args ...)
|
||||
([kw-args (code:line #:attempts attempts-expr)
|
||||
@defform*/subs[[(generate-term language @#,ttpattern size-expr kw-args ...)
|
||||
(generate-term language @#,ttpattern)]
|
||||
([kw-args (code:line #:attempt-num attempts-expr)
|
||||
(code:line #:retries retries-expr)])
|
||||
#:contracts ([size-expr natural-number/c]
|
||||
[attempt-num-expr natural-number/c]
|
||||
[retries-expr natural-number/c])]{
|
||||
Generates a random term matching @scheme[pattern] (in the given language).
|
||||
|
||||
In its first form, @scheme[generate-term] produces a random term matching
|
||||
the given pattern (according to the given language). In its second,
|
||||
@scheme[generate-term] produces a procedure for constructing the same.
|
||||
This procedure expects @scheme[size-expr] (below) as its sole positional
|
||||
argument and allows the same optional keyword arguments as the first form.
|
||||
The second form may be more efficient when generating many terms.
|
||||
|
||||
The argument @scheme[size-expr] bounds the height of the generated term
|
||||
(measured as the height of the derivation tree used to produce
|
||||
the term).
|
||||
(measured as the height of its parse tree).
|
||||
|
||||
The optional keyword argument @scheme[attempt-num-expr]
|
||||
(default @scheme[1]) provides coarse grained control over the random
|
||||
decisions made during generation. For example, the expected length of
|
||||
@pattech[pattern-sequence]s increases with @scheme[attempt-num-expr].
|
||||
decisions made during generation; increasing @scheme[attempt-num-expr]
|
||||
tends to increase the complexity of the result. For example, the expected
|
||||
length of @pattech[pattern-sequence]s increases with @scheme[attempt-num-expr].
|
||||
|
||||
The random generation process does not actively consider the constraints
|
||||
imposed by @pattech[side-condition] or @tt{_!_} @|pattern|s when
|
||||
constructing a term; instead, it tests the satisfaction of
|
||||
such constraints after it freely generates the relevant portion of the
|
||||
sub-term---regenerating the sub-term if necessary. The optional keyword
|
||||
argument @scheme[retries-expr] (default @scheme[100]) bounds the number of times that
|
||||
@scheme[generate-term] retries the generation of any sub-term. If
|
||||
imposed by @pattech[side-condition] or @tt{_!_} @|pattern|s; instead,
|
||||
it uses a ``guess and check'' strategy in which it freely generates
|
||||
candidate terms then tests whether they happen to satisfy the constraints,
|
||||
repeating as necessary. The optional keyword argument @scheme[retries-expr]
|
||||
(default @scheme[100]) bounds the number of times that
|
||||
@scheme[generate-term] retries the generation of any pattern. If
|
||||
@scheme[generate-term] is unable to produce a satisfying term after
|
||||
@scheme[retries-expr] attempts, it raises an exception recognized by
|
||||
@scheme[exn:fail:redex:generation-failure?].}
|
||||
|
|
@ -1159,11 +1166,13 @@ argument @scheme[retries-expr] (default @scheme[100]) bounds the number of times
|
|||
([kw-arg (code:line #:attempts attempts-expr)
|
||||
(code:line #:source metafunction)
|
||||
(code:line #:source relation-expr)
|
||||
(code:line #:retries retries-expr)])
|
||||
(code:line #:retries retries-expr)
|
||||
(code:line #:print? print?-expr)])
|
||||
#:contracts ([property-expr any/c]
|
||||
[attempts-expr natural-number/c]
|
||||
[relation-expr reduction-relation?]
|
||||
[retries-expr natural-number/c])]{
|
||||
[retries-expr natural-number/c]
|
||||
[print?-expr any/c])]{
|
||||
Searches for a counterexample to @scheme[property-expr], interpreted
|
||||
as a predicate universally quantified over the pattern variables
|
||||
bound by @scheme[pattern]. @scheme[redex-check] constructs and tests
|
||||
|
|
@ -1173,8 +1182,18 @@ using the @scheme[match-bindings] produced by @scheme[match]ing
|
|||
@math{t} against @scheme[pattern].
|
||||
|
||||
@scheme[redex-check] generates at most @scheme[attempts-expr] (default @scheme[1000])
|
||||
random terms in its search. The size and complexity of terms it generates
|
||||
gradually increases with each failed attempt.
|
||||
random terms in its search. The size and complexity of these terms increase with
|
||||
each failed attempt.
|
||||
|
||||
When @scheme[print?-expr] produces any non-@scheme[#f] value (the default),
|
||||
@scheme[redex-check] prints the test outcome on @scheme[current-output-port].
|
||||
When @scheme[print?-expr] produces @scheme[#f], @scheme[redex-check] prints
|
||||
nothing, instead
|
||||
@itemlist[
|
||||
@item{returning a @scheme[counterexample] structure when the test reveals a counterexample,}
|
||||
@item{returning @scheme[#t] when all tests pass, or}
|
||||
@item{raising a @scheme[exn:fail:redex:test] when checking the property raises an exception.}
|
||||
]
|
||||
|
||||
When passed a metafunction or reduction relation via the optional @scheme[#:source]
|
||||
argument, @scheme[redex-check] distributes its attempts across the left-hand sides
|
||||
|
|
@ -1221,6 +1240,16 @@ term that does not match @scheme[pattern].}
|
|||
#:attempts 3
|
||||
#:source R))]
|
||||
|
||||
@defstruct[counterexample ([term any/c])]{
|
||||
Produced by @scheme[redex-check], @scheme[check-reduction-relation], and
|
||||
@scheme[check-metafunction] when testing falsifies a property.}
|
||||
|
||||
@defstruct[(exn:fail:redex:test exn:fail:redex) ([source exn:fail?] [term any/c])]{
|
||||
Raised by @scheme[redex-check], @scheme[check-reduction-relation], and
|
||||
@scheme[check-metafunction] when testing a property raises an exception.
|
||||
The @scheme[exn:fail:redex:test-source] component contains the exception raised by the property,
|
||||
and the @scheme[exn:fail:redex:test-term] component contains the term that induced the exception.}
|
||||
|
||||
@defform/subs[(check-reduction-relation relation property kw-args ...)
|
||||
([kw-arg (code:line #:attempts attempts-expr)
|
||||
(code:line #:retries retries-expr)])
|
||||
|
|
|
|||
|
|
@ -50,7 +50,9 @@
|
|||
check-metafunction
|
||||
check-metafunction-contract
|
||||
check-reduction-relation
|
||||
exn:fail:redex:generation-failure?)
|
||||
exn:fail:redex:generation-failure?
|
||||
(struct-out exn:fail:redex:test)
|
||||
(struct-out counterexample))
|
||||
|
||||
(provide/contract
|
||||
[current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))]
|
||||
|
|
|
|||
|
|
@ -20,16 +20,15 @@
|
|||
[(_ test-exp bitmap-filename)
|
||||
#`(test/proc
|
||||
#,(syntax-line stx)
|
||||
test-exp
|
||||
(λ () test-exp)
|
||||
bitmap-filename)]))
|
||||
|
||||
(define (test/proc line-number pict raw-bitmap-filename)
|
||||
(define (test/proc line-number pict-thunk raw-bitmap-filename)
|
||||
(set! tests (+ tests 1))
|
||||
(let* ([bitmap-filename
|
||||
(let* ([pict (set-fonts/call pict-thunk)]
|
||||
[bitmap-filename
|
||||
(build-path (format "bmps-~a" (system-type))
|
||||
(case (system-type)
|
||||
[(unix) (string-append "unix-" raw-bitmap-filename)]
|
||||
[else raw-bitmap-filename]))]
|
||||
raw-bitmap-filename)]
|
||||
[old-bitmap (if (file-exists? bitmap-filename)
|
||||
(make-object bitmap% bitmap-filename)
|
||||
(let* ([bm (make-object bitmap% 100 20)]
|
||||
|
|
@ -39,8 +38,8 @@
|
|||
(send bdc set-bitmap #f)
|
||||
bm))]
|
||||
[new-bitmap (make-object bitmap%
|
||||
(inexact->exact (pict-width pict))
|
||||
(inexact->exact (pict-height pict)))]
|
||||
(ceiling (inexact->exact (pict-width pict)))
|
||||
(ceiling (inexact->exact (pict-height pict))))]
|
||||
[bdc (make-object bitmap-dc% new-bitmap)])
|
||||
(send bdc clear)
|
||||
(draw-pict pict bdc 0 0)
|
||||
|
|
@ -50,6 +49,33 @@
|
|||
(let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap diff-bitmap)])
|
||||
(set! failed (append failed (list failed-panel))))))))
|
||||
|
||||
(define (set-fonts/call thunk)
|
||||
(case (system-type)
|
||||
[(unix)
|
||||
(let ([rewrite-style
|
||||
(λ (s)
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(pair? s) (cons (loop (car s)) (loop (cdr s)))]
|
||||
[(eq? s 'roman) (verify-face " DejaVu Serif")]
|
||||
[(eq? s 'swiss) (verify-face " DejaVu Sans")]
|
||||
[else s])))])
|
||||
(parameterize ([label-style (rewrite-style (label-style))]
|
||||
[literal-style (rewrite-style (literal-style))]
|
||||
[metafunction-style (rewrite-style (metafunction-style))]
|
||||
[non-terminal-style (rewrite-style (non-terminal-style))]
|
||||
[non-terminal-subscript-style (rewrite-style (non-terminal-subscript-style))]
|
||||
[non-terminal-superscript-style (rewrite-style (non-terminal-superscript-style))]
|
||||
[default-style (rewrite-style (default-style))])
|
||||
(thunk)))]
|
||||
[else
|
||||
(thunk)]))
|
||||
|
||||
(define (verify-face face)
|
||||
(unless (member face (get-face-list))
|
||||
(error 'verify-face "unknown face: ~s" face))
|
||||
face)
|
||||
|
||||
(define (compute-diffs old-bitmap new-bitmap)
|
||||
(let* ([w (max (send old-bitmap get-width)
|
||||
(send new-bitmap get-width))]
|
||||
|
Before Width: | Height: | Size: 1.9 KiB After Width: | Height: | Size: 1.9 KiB |
|
Before Width: | Height: | Size: 394 B After Width: | Height: | Size: 394 B |
|
Before Width: | Height: | Size: 2.9 KiB After Width: | Height: | Size: 2.9 KiB |
|
Before Width: | Height: | Size: 5.9 KiB After Width: | Height: | Size: 5.9 KiB |
|
Before Width: | Height: | Size: 1.2 KiB After Width: | Height: | Size: 1.2 KiB |
|
Before Width: | Height: | Size: 4.7 KiB After Width: | Height: | Size: 4.7 KiB |
|
Before Width: | Height: | Size: 4.3 KiB After Width: | Height: | Size: 4.3 KiB |
|
Before Width: | Height: | Size: 4.6 KiB After Width: | Height: | Size: 4.6 KiB |
|
Before Width: | Height: | Size: 4.6 KiB After Width: | Height: | Size: 4.6 KiB |
|
Before Width: | Height: | Size: 8.3 KiB After Width: | Height: | Size: 8.3 KiB |
|
Before Width: | Height: | Size: 4.3 KiB After Width: | Height: | Size: 4.3 KiB |
|
Before Width: | Height: | Size: 1.1 KiB After Width: | Height: | Size: 1.1 KiB |
|
Before Width: | Height: | Size: 9.1 KiB After Width: | Height: | Size: 9.1 KiB |
|
Before Width: | Height: | Size: 5.1 KiB After Width: | Height: | Size: 5.1 KiB |
|
Before Width: | Height: | Size: 1.8 KiB After Width: | Height: | Size: 1.8 KiB |
|
Before Width: | Height: | Size: 944 B After Width: | Height: | Size: 944 B |
|
Before Width: | Height: | Size: 2.1 KiB After Width: | Height: | Size: 2.1 KiB |
|
Before Width: | Height: | Size: 507 B After Width: | Height: | Size: 507 B |
|
Before Width: | Height: | Size: 3.1 KiB After Width: | Height: | Size: 3.1 KiB |
|
Before Width: | Height: | Size: 5.5 KiB After Width: | Height: | Size: 5.5 KiB |
|
Before Width: | Height: | Size: 1.2 KiB After Width: | Height: | Size: 1.2 KiB |
|
Before Width: | Height: | Size: 4.4 KiB After Width: | Height: | Size: 4.4 KiB |
|
Before Width: | Height: | Size: 3.7 KiB After Width: | Height: | Size: 3.7 KiB |
|
Before Width: | Height: | Size: 3.9 KiB After Width: | Height: | Size: 3.9 KiB |
|
Before Width: | Height: | Size: 4.4 KiB After Width: | Height: | Size: 4.4 KiB |
|
Before Width: | Height: | Size: 7.0 KiB After Width: | Height: | Size: 7.0 KiB |
|
Before Width: | Height: | Size: 5.2 KiB After Width: | Height: | Size: 5.2 KiB |
|
Before Width: | Height: | Size: 1.1 KiB After Width: | Height: | Size: 1.1 KiB |
|
Before Width: | Height: | Size: 10 KiB After Width: | Height: | Size: 10 KiB |
|
Before Width: | Height: | Size: 1.9 KiB After Width: | Height: | Size: 1.9 KiB |
BIN
collects/redex/tests/bmps-unix/extended-language.png
Normal file
BIN
collects/redex/tests/bmps-unix/extended-language.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 2.5 KiB |
BIN
collects/redex/tests/bmps-unix/extended-reduction-relation.png
Normal file
BIN
collects/redex/tests/bmps-unix/extended-reduction-relation.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 551 B |
BIN
collects/redex/tests/bmps-unix/language-nox.png
Normal file
BIN
collects/redex/tests/bmps-unix/language-nox.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 3.6 KiB |
BIN
collects/redex/tests/bmps-unix/language.png
Normal file
BIN
collects/redex/tests/bmps-unix/language.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 6.7 KiB |
BIN
collects/redex/tests/bmps-unix/lw.png
Normal file
BIN
collects/redex/tests/bmps-unix/lw.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.4 KiB |
BIN
collects/redex/tests/bmps-unix/metafunction-Name-vertical.png
Normal file
BIN
collects/redex/tests/bmps-unix/metafunction-Name-vertical.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 5.0 KiB |
BIN
collects/redex/tests/bmps-unix/metafunction-Name.png
Normal file
BIN
collects/redex/tests/bmps-unix/metafunction-Name.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.6 KiB |
BIN
collects/redex/tests/bmps-unix/metafunction-T.png
Normal file
BIN
collects/redex/tests/bmps-unix/metafunction-T.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 5.7 KiB |
BIN
collects/redex/tests/bmps-unix/metafunction-TL.png
Normal file
BIN
collects/redex/tests/bmps-unix/metafunction-TL.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.8 KiB |
BIN
collects/redex/tests/bmps-unix/metafunction-multi-arg.png
Normal file
BIN
collects/redex/tests/bmps-unix/metafunction-multi-arg.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 7.5 KiB |
BIN
collects/redex/tests/bmps-unix/metafunction-subst.png
Normal file
BIN
collects/redex/tests/bmps-unix/metafunction-subst.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 5.4 KiB |
BIN
collects/redex/tests/bmps-unix/metafunction.png
Normal file
BIN
collects/redex/tests/bmps-unix/metafunction.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.2 KiB |
BIN
collects/redex/tests/bmps-unix/metafunctions-multiple.png
Normal file
BIN
collects/redex/tests/bmps-unix/metafunctions-multiple.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 13 KiB |
BIN
collects/redex/tests/bmps-unix/red2.png
Normal file
BIN
collects/redex/tests/bmps-unix/red2.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 6.8 KiB |
BIN
collects/redex/tests/bmps-unix/reduction-relation.png
Normal file
BIN
collects/redex/tests/bmps-unix/reduction-relation.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 2.2 KiB |
BIN
collects/redex/tests/bmps-unix/superscripts.png
Normal file
BIN
collects/redex/tests/bmps-unix/superscripts.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 1.2 KiB |
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "core-layout.ss"
|
||||
"loc-wrapper.ss"
|
||||
(require "../private/core-layout.ss"
|
||||
"../private/loc-wrapper.ss"
|
||||
"lw-test-util.ss"
|
||||
"test-util.ss"
|
||||
(lib "struct.ss"))
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme
|
||||
|
||||
(require "keyword-macros.ss"
|
||||
(require "../private/keyword-macros.ss"
|
||||
"test-util.ss")
|
||||
|
||||
(reset-count)
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
(module lw-test-util mzscheme
|
||||
(require "loc-wrapper.ss")
|
||||
(require "../private/loc-wrapper.ss")
|
||||
(provide normalize-lw)
|
||||
|
||||
(define (normalize-lw lw)
|
||||
|
|
@ -51,7 +51,7 @@
|
|||
|
||||
(module lw-test mzscheme
|
||||
(require "test-util.ss"
|
||||
"loc-wrapper.ss"
|
||||
"../private/loc-wrapper.ss"
|
||||
"lw-test-util.ss")
|
||||
|
||||
(reset-count)
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
(module matcher-test mzscheme
|
||||
(require "matcher.ss"
|
||||
(require "../private/matcher.ss"
|
||||
(only "test-util.ss" equal/bindings?)
|
||||
(lib "list.ss"))
|
||||
|
||||
|
|
@ -1,12 +1,15 @@
|
|||
#lang scheme
|
||||
|
||||
(require "test-util.ss"
|
||||
"reduction-semantics.ss"
|
||||
"matcher.ss"
|
||||
"term.ss"
|
||||
"rg.ss"
|
||||
"keyword-macros.ss"
|
||||
"error.ss")
|
||||
"../private/reduction-semantics.ss"
|
||||
"../private/matcher.ss"
|
||||
"../private/term.ss"
|
||||
"../private/rg.ss"
|
||||
"../private/keyword-macros.ss"
|
||||
"../private/error.ss")
|
||||
|
||||
(define-namespace-anchor nsa)
|
||||
(define ns (namespace-anchor->namespace nsa))
|
||||
|
||||
(reset-count)
|
||||
|
||||
|
|
@ -111,23 +114,6 @@
|
|||
(test (pick-string lits 0 (make-random .5 1 0 1 1 1 2 1)) "abc")
|
||||
(test (pick-var lits 0 (make-random .01 1 0 1 1 1 2 1)) 'abc))
|
||||
|
||||
(let ()
|
||||
(define-language L
|
||||
(a 5 (x a))
|
||||
(b 4))
|
||||
(test (pick-nt 'a #f L 1 'dontcare)
|
||||
(nt-rhs (car (compiled-lang-lang L))))
|
||||
(test (pick-nt 'a #f L preferred-production-threshold 'dontcare (make-random 1))
|
||||
(nt-rhs (car (compiled-lang-lang L))))
|
||||
(let ([pref (car (nt-rhs (car (compiled-lang-lang L))))])
|
||||
(test (pick-nt 'a #f L preferred-production-threshold
|
||||
(make-pref-prods 'dont-care
|
||||
(make-immutable-hash `((a ,pref))))
|
||||
(make-random 0))
|
||||
(list pref)))
|
||||
(test (pick-nt 'b #f L preferred-production-threshold #f)
|
||||
(nt-rhs (cadr (compiled-lang-lang L)))))
|
||||
|
||||
(define-syntax raised-exn-msg
|
||||
(syntax-rules ()
|
||||
[(_ expr) (raised-exn-msg exn:fail? expr)]
|
||||
|
|
@ -141,7 +127,7 @@
|
|||
|
||||
(define (patterns . selectors)
|
||||
(map (λ (selector)
|
||||
(λ (name cross? lang size pref-prods)
|
||||
(λ (name cross? lang sizes)
|
||||
(list (selector (nt-rhs (nt-by-name lang name cross?))))))
|
||||
selectors))
|
||||
|
||||
|
|
@ -158,15 +144,14 @@
|
|||
(test (raised-exn-msg (iter)) #rx"empty"))
|
||||
|
||||
(define (decisions #:var [var pick-var]
|
||||
#:nt [nt pick-nt]
|
||||
#:nt [nt pick-nts]
|
||||
#:str [str pick-string]
|
||||
#:num [num pick-number]
|
||||
#:nat [nat pick-natural]
|
||||
#:int [int pick-integer]
|
||||
#:real [real pick-real]
|
||||
#:any [any pick-any]
|
||||
#:seq [seq pick-sequence-length]
|
||||
#:pref [pref pick-preferred-productions])
|
||||
#:seq [seq pick-sequence-length])
|
||||
(define-syntax decision
|
||||
(syntax-rules ()
|
||||
[(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))]))
|
||||
|
|
@ -179,14 +164,13 @@
|
|||
(define next-real-decision (decision real))
|
||||
(define next-string-decision (decision str))
|
||||
(define next-any-decision (decision any))
|
||||
(define next-sequence-decision (decision seq))
|
||||
(define next-pref-prods-decision (decision pref))))
|
||||
(define next-sequence-decision (decision seq))))
|
||||
|
||||
(define-syntax generate-term/decisions
|
||||
(syntax-rules ()
|
||||
[(_ lang pat size attempt decisions)
|
||||
(parameterize ([generation-decisions decisions])
|
||||
(generate-term lang pat size #:attempt attempt))]))
|
||||
(generate-term lang pat size #:attempt-num attempt))]))
|
||||
|
||||
(let ()
|
||||
(define-language lc
|
||||
|
|
@ -216,6 +200,17 @@
|
|||
#:var (list (λ _ 'x) (λ _ 'y))))
|
||||
'(x y)))
|
||||
|
||||
(let ()
|
||||
(define-language L
|
||||
(n 1))
|
||||
(test ((generate-term L n) 0) 1)
|
||||
(test ((generate-term L n) 0 #:retries 0) 1)
|
||||
(test ((generate-term L n) 0 #:attempt-num 0) 1)
|
||||
(test (with-handlers ([exn:fail:syntax? exn-message])
|
||||
(parameterize ([current-namespace ns])
|
||||
(expand #'(generate-term M n))))
|
||||
#rx"generate-term: expected a identifier defined by define-language( in: M)?$"))
|
||||
|
||||
;; variable-except pattern
|
||||
(let ()
|
||||
(define-language var
|
||||
|
|
@ -231,17 +226,17 @@
|
|||
(n natural)
|
||||
(i integer)
|
||||
(r real))
|
||||
(test (let ([n (generate-term L n 0 #:attempt 10000)])
|
||||
(test (let ([n (generate-term L n 0 #:attempt-num 10000)])
|
||||
(and (integer? n)
|
||||
(exact? n)
|
||||
(not (negative? n))))
|
||||
#t)
|
||||
(test (generate-term/decisions L n 0 1 (decisions #:nat (λ (_) 42))) 42)
|
||||
(test (let ([i (generate-term L i 0 #:attempt 10000)])
|
||||
(test (let ([i (generate-term L i 0 #:attempt-num 10000)])
|
||||
(and (integer? i) (exact? i)))
|
||||
#t)
|
||||
(test (generate-term/decisions L i 0 1 (decisions #:int (λ (_) -42))) -42)
|
||||
(test (real? (generate-term L r 0 #:attempt 10000)) #t)
|
||||
(test (real? (generate-term L r 0 #:attempt-num 10000)) #t)
|
||||
(test (generate-term/decisions L r 0 1 (decisions #:real (λ (_) 4.2))) 4.2))
|
||||
|
||||
(let ()
|
||||
|
|
@ -539,77 +534,22 @@
|
|||
(get-output-string p)
|
||||
(close-output-port p))))
|
||||
|
||||
;; preferred productions
|
||||
(let ([make-pick-nt (λ opt (λ req (apply pick-nt (append req opt))))])
|
||||
(define-language L
|
||||
(e (+ e e) (* e e) 7))
|
||||
(define-language M (e 0) (e-e 1))
|
||||
|
||||
(let ([pats (λ (L) (nt-rhs (car (compiled-lang-lang L))))])
|
||||
(test
|
||||
(generate-term/decisions
|
||||
L e 2 preferred-production-threshold
|
||||
(decisions #:pref (list (λ (L) (make-pref-prods
|
||||
'dont-care
|
||||
(make-immutable-hash `((e ,(car (pats L))))))))
|
||||
#:nt (make-pick-nt (make-random 0 0 0))))
|
||||
'(+ (+ 7 7) (+ 7 7)))
|
||||
(test
|
||||
(generate-term/decisions
|
||||
L any 2 preferred-production-threshold
|
||||
(decisions #:nt (patterns first)
|
||||
#:var (list (λ _ 'x))
|
||||
#:any (list (λ (lang sexp) (values sexp 'sexp)))))
|
||||
'x)
|
||||
(test
|
||||
(generate-term/decisions
|
||||
L any 2 preferred-production-threshold
|
||||
(decisions #:pref (list (λ (L) (make-pref-prods
|
||||
'dont-care
|
||||
(make-immutable-hash `((e ,(car (pats L))))))))
|
||||
#:nt (make-pick-nt (make-random 0 0 0))
|
||||
#:any (list (λ (lang sexp) (values lang 'e)))))
|
||||
'(+ (+ 7 7) (+ 7 7)))
|
||||
(test
|
||||
(generate-term/decisions
|
||||
M (cross e) 2 preferred-production-threshold
|
||||
(decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t))))
|
||||
(term hole))
|
||||
(test
|
||||
(generate-term/decisions
|
||||
M e-e 2 preferred-production-threshold
|
||||
(decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t))))
|
||||
1)
|
||||
|
||||
(test
|
||||
(let ([generated null])
|
||||
(output
|
||||
(λ ()
|
||||
(check-reduction-relation
|
||||
(reduction-relation L (--> e e))
|
||||
(λ (t) (set! generated (cons t generated)))
|
||||
#:decisions (decisions #:nt (make-pick-nt (make-random)
|
||||
(λ (att rand) #t))
|
||||
#:pref (list (λ (_) 'dontcare)
|
||||
(λ (_) 'dontcare)
|
||||
(λ (_) 'dontcare)
|
||||
; size 0 terms prior to this attempt
|
||||
(λ (L) (make-pref-prods
|
||||
'dont-care
|
||||
(make-immutable-hash `((e ,(car (pats L)))))))
|
||||
(λ (L) (make-pref-prods
|
||||
'dont-care
|
||||
(make-immutable-hash `((e ,(cadr (pats L)))))))))
|
||||
#:attempts 5)))
|
||||
generated)
|
||||
'((* 7 7) (+ 7 7) 7 7 7))))
|
||||
|
||||
;; redex-check
|
||||
(let ()
|
||||
(define-language lang
|
||||
(d 5)
|
||||
(e e 4)
|
||||
(n number))
|
||||
|
||||
(test (redex-check lang d #t #:attempts 1 #:print? (not #t)) #t)
|
||||
(test (counterexample-term (redex-check lang d #f #:print? #f)) 5)
|
||||
(let ([exn (with-handlers ([exn:fail:redex:test? values])
|
||||
(redex-check lang d (error 'boom ":(") #:print? #f)
|
||||
'not-an-exn)])
|
||||
(test (exn-message exn) "checking 5 raises an exception:\nboom: :(")
|
||||
(test (exn-message (exn:fail:redex:test-source exn)) "boom: :(")
|
||||
(test (exn:fail:redex:test-term exn) 5))
|
||||
|
||||
(test (output (λ () (redex-check lang d #f)))
|
||||
#rx"redex-check: .*:.*\ncounterexample found after 1 attempt:\n5\n")
|
||||
(test (output (λ () (redex-check lang d #t)))
|
||||
|
|
@ -644,17 +584,29 @@
|
|||
(--> 0 dontcare z)))))
|
||||
#rx"counterexample found after 1 attempt with z:\n0\n")
|
||||
|
||||
(let ([generated null])
|
||||
(let ([generated null]
|
||||
[R (reduction-relation
|
||||
lang
|
||||
(--> 1 dontcare)
|
||||
(--> 2 dontcare))])
|
||||
(test (output
|
||||
(λ ()
|
||||
(redex-check lang n (set! generated (cons (term n) generated))
|
||||
#:attempts 5
|
||||
#:source (reduction-relation
|
||||
lang
|
||||
(--> 1 dontcare)
|
||||
(--> 2 dontcare)))))
|
||||
#:source R)))
|
||||
#rx"no counterexamples.*with each clause")
|
||||
(test generated '(2 2 1 1)))
|
||||
(test generated '(2 2 1 1))
|
||||
|
||||
(test (redex-check lang any #t
|
||||
#:attempts 1
|
||||
#:source R
|
||||
#:print? (not #t))
|
||||
#t)
|
||||
(test (counterexample-term
|
||||
(redex-check lang any (= (term any) 1)
|
||||
#:source R
|
||||
#:print? #f))
|
||||
2))
|
||||
|
||||
(let ()
|
||||
(define-metafunction lang
|
||||
|
|
@ -665,7 +617,17 @@
|
|||
(redex-check lang (n) (eq? 42 (term n))
|
||||
#:attempts 1
|
||||
#:source mf)))
|
||||
#px"counterexample found after 1 attempt with clause at .*:\\d+:\\d+:\n\\(0\\)\n"))
|
||||
#px"counterexample found after 1 attempt with clause at .*:\\d+:\\d+:\n\\(0\\)\n")
|
||||
(test (redex-check lang any #t
|
||||
#:attempts 1
|
||||
#:source mf
|
||||
#:print? (not #t))
|
||||
#t)
|
||||
(test (counterexample-term
|
||||
(redex-check lang any (= (car (term any)) 42)
|
||||
#:source mf
|
||||
#:print? #f))
|
||||
'(0)))
|
||||
|
||||
(let ()
|
||||
(define-metafunction lang
|
||||
|
|
@ -790,6 +752,14 @@
|
|||
(E* hole E*)
|
||||
(n 4))
|
||||
|
||||
(let ([R (reduction-relation
|
||||
L
|
||||
(--> 1 2)
|
||||
(--> 2 3))])
|
||||
(test (check-reduction-relation R (λ (_) #t) #:print? #f) #t)
|
||||
(test (counterexample-term (check-reduction-relation R (curry = 1) #:print? #f))
|
||||
2))
|
||||
|
||||
(let ([generated null]
|
||||
[R (reduction-relation
|
||||
L
|
||||
|
|
@ -857,6 +827,11 @@
|
|||
(define-metafunction empty
|
||||
[(n (side-condition any #f)) any])
|
||||
|
||||
(test (check-metafunction m (λ (_) #t) #:print? #f) #t)
|
||||
(test (counterexample-term
|
||||
(check-metafunction m (compose (curry = 1) car) #:print? #f))
|
||||
'(2))
|
||||
|
||||
(let ([generated null])
|
||||
(test (begin
|
||||
(output
|
||||
|
|
@ -890,89 +865,6 @@
|
|||
(check-metafunction n (λ (_) #t) #:retries 42))
|
||||
#rx"check-metafunction: unable .* in 42"))
|
||||
|
||||
;; custom generators
|
||||
(let ()
|
||||
(define-language L
|
||||
(x variable))
|
||||
|
||||
(test
|
||||
(generate-term
|
||||
L x_1 0
|
||||
#:custom (λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
['x (values 'x env)]
|
||||
[_ (def acc)])))
|
||||
'x)
|
||||
(test
|
||||
(let/ec k
|
||||
(equal?
|
||||
(generate-term
|
||||
L (x x) 0
|
||||
#:custom (let ([once? #f])
|
||||
(λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
['x (if once?
|
||||
(k #f)
|
||||
(begin
|
||||
(set! once? #t)
|
||||
(values 'x env)))]
|
||||
[_ (def acc)]))))
|
||||
'(x x)))
|
||||
#t)
|
||||
|
||||
(test
|
||||
(hash-ref
|
||||
(let/ec k
|
||||
(generate-term
|
||||
L (x (x)) 0
|
||||
#:custom (λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
[(struct binder ('x))
|
||||
(values 'y (hash-set env pat 'y))]
|
||||
[(list (struct binder ('x))) (k env)]
|
||||
[_ (def acc)]))))
|
||||
(make-binder 'x))
|
||||
'y)
|
||||
|
||||
(test
|
||||
(generate-term
|
||||
L (in-hole hole 7) 0
|
||||
#:custom (λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
[`(in-hole hole 7)
|
||||
(rec 'hole #:contractum 7)]
|
||||
[_ (def acc)])))
|
||||
7)
|
||||
|
||||
(test
|
||||
(let/ec k
|
||||
(generate-term
|
||||
L any 10
|
||||
#:attempt 42
|
||||
#:custom (λ (pat sz i-h acc env att rec def) (k (list sz att)))))
|
||||
'(10 42))
|
||||
|
||||
(test
|
||||
(let/ec k
|
||||
(generate-term
|
||||
L x 10
|
||||
#:custom (λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
['x (rec 7 #:size 0)]
|
||||
[7 (k sz)]
|
||||
[_ (def att)]))))
|
||||
0)
|
||||
|
||||
(test
|
||||
(generate-term
|
||||
L (q 7) 0
|
||||
#:custom (λ (pat sz i-h acc env att rec def)
|
||||
(match pat
|
||||
['q (rec '(7 7) #:acc 8)]
|
||||
[7 (values (or acc 7) env)]
|
||||
[_ (def att)])))
|
||||
'((8 8) 7)))
|
||||
|
||||
;; parse/unparse-pattern
|
||||
(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])])
|
||||
(define-language lang (x variable))
|
||||
|
|
@ -5,7 +5,7 @@
|
|||
"config.ss"
|
||||
"test-util.ss")
|
||||
|
||||
(set-show-bitmaps? #t)
|
||||
(set-show-bitmaps? #f)
|
||||
|
||||
(define test-files
|
||||
'("lw-test.ss"
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
(module term-test scheme
|
||||
(require "term.ss"
|
||||
"matcher.ss"
|
||||
(require "../private/term.ss"
|
||||
"../private/matcher.ss"
|
||||
"test-util.ss")
|
||||
|
||||
(reset-count)
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme
|
||||
|
||||
(require "matcher.ss"
|
||||
(require "../private/matcher.ss"
|
||||
errortrace/errortrace-lib
|
||||
errortrace/errortrace-key)
|
||||
(provide test test-syn-err tests reset-count
|
||||
|
|
@ -129,4 +129,4 @@
|
|||
(let ([p (read-syntax src (open-input-string (format "~s" sexp)))])
|
||||
(with-handlers ((exn:srclocs? (λ (x) (map srcloc-source ((exn:srclocs-accessor x) x)))))
|
||||
(expand p)
|
||||
null)))
|
||||
null)))
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
(module tl-test scheme
|
||||
(require "../reduction-semantics.ss"
|
||||
"test-util.ss"
|
||||
(only-in "matcher.ss" make-bindings make-bind)
|
||||
(only-in "../private/matcher.ss" make-bindings make-bind)
|
||||
scheme/match
|
||||
"struct.ss")
|
||||
"../private/struct.ss")
|
||||
|
||||
(reset-count)
|
||||
|
||||
|
|
@ -1 +1 @@
|
|||
#lang scheme/base (provide stamp) (define stamp "25jan2010")
|
||||
#lang scheme/base (provide stamp) (define stamp "28jan2010")
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/port
|
||||
scheme/path
|
||||
scheme/list
|
||||
scheme/string
|
||||
syntax/moddep
|
||||
|
|
@ -444,7 +445,7 @@
|
|||
(cond [(and p (null? (cdr inps)))
|
||||
(port-count-lines! p)
|
||||
(parameterize ([current-input-port p])
|
||||
(begin0 ((sandbox-reader) source)
|
||||
(begin0 ((sandbox-reader) (or (object-name p) source))
|
||||
;; close a port if we opened it
|
||||
(unless (eq? p (car inps)) (close-input-port p))))]
|
||||
[p (error 'input->code "ambiguous inputs: ~e" inps)]
|
||||
|
|
@ -550,11 +551,17 @@
|
|||
(module->namespace `(quote ,(syntax-e mod)))))]
|
||||
[_else #f])])
|
||||
;; the actual evaluation happens under the specified limits
|
||||
((limit-thunk (lambda ()
|
||||
(if (and (pair? program) (eq? 'begin (car program)))
|
||||
(eval* (cdr program))
|
||||
(eval program))
|
||||
(when ns (set! ns (ns))))))
|
||||
(parameterize ([current-load-relative-directory
|
||||
(let* ([d (and (syntax? program) (syntax-source program))]
|
||||
[d (and (path-string? d) (path-only d))])
|
||||
(if (and d (directory-exists? d))
|
||||
d
|
||||
(current-load-relative-directory)))])
|
||||
((limit-thunk (lambda ()
|
||||
(if (and (pair? program) (eq? 'begin (car program)))
|
||||
(eval* (cdr program))
|
||||
(eval program))
|
||||
(when ns (set! ns (ns)))))))
|
||||
(when uncovered!
|
||||
(let ([get (let ([ns (current-namespace)])
|
||||
(lambda () (eval '(get-uncovered-expressions) ns)))])
|
||||
|
|
|
|||
|
|
@ -40,7 +40,6 @@
|
|||
(dynamic-require 'scribble/run #f)
|
||||
(cond
|
||||
[(equal? label "HTML")
|
||||
(system (format "firefox ~a" (path-replace-suffix name suffix)))
|
||||
(send-url/file (path-replace-suffix fn suffix))]
|
||||
[else (system (format "open ~a" (path-replace-suffix name suffix)))]))
|
||||
(message-box "Scribble" (get-output-string p) drs-frame))
|
||||
|
|
|
|||
|
|
@ -203,7 +203,7 @@ information@|details|, even if the editor currently has delayed refreshing (see
|
|||
monitor @|whatsit| changes.})
|
||||
|
||||
(define (MonitorCallbackX a b c d)
|
||||
(MonitorMethod a b @elem{the @|d|callback procedure (provided as an initialization argument)} c))
|
||||
(MonitorMethod a b @elem{the @|d| callback procedure (provided as an initialization argument)} c))
|
||||
|
||||
(define (MonitorCallback a b c)
|
||||
(MonitorCallbackX a b c "control"))
|
||||
|
|
|
|||
|
|
@ -530,7 +530,7 @@ When an editor is loaded and a header/footer record is encountered,
|
|||
be loaded.
|
||||
|
||||
See also @method[editor<%> write-headers-to-file] and
|
||||
@method[editor<%> write-headers-to-file].
|
||||
@method[editor<%> read-header-from-file].
|
||||
|
||||
|
||||
@section[#:tag "editoreol"]{End of Line Ambiguity}
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ Whenever the user changes the selected radio button, the radio box's
|
|||
'vertical-label 'horizontal-label
|
||||
'deleted))
|
||||
'(vertical)]
|
||||
[selection exact-nonnegative-integer? 0]
|
||||
[selection (or/c exact-nonnegative-integer? #f) 0]
|
||||
[font (is-a?/c font%) normal-control-font]
|
||||
[enabled any/c #t]
|
||||
[vert-margin (integer-in 0 1000) 2]
|
||||
|
|
@ -64,8 +64,9 @@ The @scheme[style] argument must include either @scheme['vertical] for a
|
|||
@HVLabelNote[@scheme[style]]{radio box} @DeletedStyleNote[@scheme[style] @scheme[parent]]{radio box}
|
||||
|
||||
By default, the first radio button is initially selected. If
|
||||
@scheme[selection] is positive, it is passed to @method[radio-box%
|
||||
set-selection] to set the initial radio button selection.
|
||||
@scheme[selection] is positive or @scheme[#f], it is passed to
|
||||
@method[radio-box% set-selection] to set the initial radio button
|
||||
selection.
|
||||
|
||||
@FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[]
|
||||
|
||||
|
|
@ -115,10 +116,10 @@ Returns the number of radio buttons in the radio box.
|
|||
}
|
||||
|
||||
@defmethod[(get-selection)
|
||||
exact-nonnegative-integer?]{
|
||||
(or/c exact-nonnegative-integer? #f)]{
|
||||
|
||||
Gets the position of the selected radio button. Radio buttons are
|
||||
numbered from @scheme[0].
|
||||
Gets the position of the selected radio button, returning @scheme[#f]
|
||||
if no button is selected. Radio buttons are numbered from @scheme[0].
|
||||
|
||||
}
|
||||
|
||||
|
|
@ -139,10 +140,11 @@ box, @|MismatchExn|.
|
|||
|
||||
}
|
||||
|
||||
@defmethod[(set-selection [n exact-nonnegative-integer?])
|
||||
@defmethod[(set-selection [n (or/c exact-nonnegative-integer? #f)])
|
||||
void?]{
|
||||
|
||||
Sets the selected radio button by position. (The control's callback
|
||||
Sets the selected radio button by position, or deselects all radio
|
||||
buttons if @scheme[n] is @scheme[#f]. (The control's callback
|
||||
procedure is @italic{not} invoked.) Radio buttons are numbered from
|
||||
@scheme[0]. If @scheme[n] is equal to or larger than the number of
|
||||
radio buttons in the radio box, @|MismatchExn|.
|
||||
|
|
|
|||
3
collects/scribblings/places/info.ss
Normal file
3
collects/scribblings/places/info.ss
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define scribblings '(("places.scrbl" ())))
|
||||
90
collects/scribblings/places/places.scrbl
Normal file
90
collects/scribblings/places/places.scrbl
Normal file
|
|
@ -0,0 +1,90 @@
|
|||
#lang scribble/doc
|
||||
|
||||
@title{@bold{Places}: Coarse-grained Parallelism}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@(require scribble/manual
|
||||
scribble/urls
|
||||
scribble/struct
|
||||
(for-label scheme
|
||||
scheme/base
|
||||
scheme/contract
|
||||
scheme/place))
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
The PLT futures API enables the development of parallel programs which
|
||||
take advantage of machines with multiple processors, cores, or
|
||||
hardware threads.
|
||||
|
||||
@defmodule[scheme/place]{}
|
||||
|
||||
@defproc[(place [module-path module-path?] [start-proc proc?] [place-channel place-ch?]) place?]{
|
||||
Starts running @scheme[start-proc] in parallel. scheme[start-proc] must
|
||||
be a function defined in @scheme[module-path]. The @scheme[place]
|
||||
procedure returns immediately with a place descriptor value.
|
||||
}
|
||||
|
||||
@defproc[(place-wait [p place?]) exact-integer?]{
|
||||
Returns the return value of a completed place @scheme[p], blocking until
|
||||
the place completes (if it has not already completed).
|
||||
}
|
||||
|
||||
@defproc[(place? [x any/c]) boolean?]{
|
||||
Returns @scheme[#t] if @scheme[x] is a place.
|
||||
}
|
||||
|
||||
@defproc[(place-ch-send [ch place-ch?] [x any/c]) void]{
|
||||
Sends an immutable message @scheme[x] on channel @scheme[ch].
|
||||
}
|
||||
|
||||
@defproc[(place-ch-recv [p place-ch?]) any/c]{
|
||||
Returns an immutable message received on channel @scheme[ch].
|
||||
}
|
||||
|
||||
@defproc[(place-ch? [x any/c]) boolean?]{
|
||||
Returns @scheme[#t] if @scheme[x] is a place-ch.
|
||||
}
|
||||
|
||||
@section[#:tag "example"]{How Do I Keep Those Cores Busy?}
|
||||
|
||||
This code launches two places passing 1 and 2 as the initial channels
|
||||
and then waits for the places to complete and return.
|
||||
|
||||
@schemeblock[
|
||||
(let ((pls (map (lambda (x) (place "place_worker.ss" 'place-main x))
|
||||
(list 1 2))))
|
||||
(map place-wait pls))
|
||||
]
|
||||
|
||||
This is the code for the place_worker.ss module that each place will execute.
|
||||
|
||||
@schemeblock[
|
||||
(module place_worker scheme
|
||||
(provide place-main)
|
||||
|
||||
(define (place-main x)
|
||||
(printf "IN PLACE ~a~n" x)))
|
||||
]
|
||||
|
||||
|
||||
@section[#:tag "messagepassingparallelism"]{Message Passing Parallelism}
|
||||
|
||||
Places can only communicate by passing immutable messages on place-channels.
|
||||
|
||||
@section[#:tag "logging"]{Architecture and Garbage Collection}
|
||||
|
||||
Immutable messages communicated on place-channels are first copied to a shared
|
||||
garbage collector called the master. The master waits on a barrier until all places garbage
|
||||
collectors have collected. Once the master is released it collects and resets
|
||||
the barrier.
|
||||
|
||||
@section[#:tag "compiling"]{Enabling Places in MzScheme Builds}
|
||||
|
||||
PLT's parallel-places support is only enabled if you pass
|
||||
@DFlag{enable-places} to @exec{configure} when you build PLT (and
|
||||
that build currently only works with @exec{mzscheme}, not with
|
||||
@exec{mred}). When parallel-future support is not enabled,
|
||||
@scheme[place] usage is a syntax error.
|
||||
@; @FIXME{use threads to emulate places maybe?}
|
||||
|
|
@ -811,7 +811,7 @@ in a way that depends on the setting of @scheme[(sandbox-output)] or
|
|||
|
||||
Retrieves uncovered expression from an evaluator, as longs as the
|
||||
@scheme[sandbox-coverage-enabled] parameter had a true value when the
|
||||
evaluator was created. Otherwise, and exception is raised to indicate
|
||||
evaluator was created. Otherwise, an exception is raised to indicate
|
||||
that no coverage information is available.
|
||||
|
||||
The @scheme[prog?] argument specifies whether to obtain expressions that
|
||||
|
|
|
|||
|
|
@ -427,10 +427,11 @@
|
|||
(memq 'depends-all-main (doc-flags doc)))
|
||||
(and auto-user?
|
||||
(memq 'depends-all (doc-flags doc)))))])
|
||||
(setup-printf
|
||||
(cond [up-to-date? "using"] [can-run? "running"] [else "skipping"])
|
||||
"~a"
|
||||
(path->name (doc-src-file doc)))
|
||||
(when (or (not up-to-date?) (verbose))
|
||||
(setup-printf
|
||||
(cond [up-to-date? "using"] [can-run? "running"] [else "skipping"])
|
||||
"~a"
|
||||
(path->name (doc-src-file doc))))
|
||||
(if up-to-date?
|
||||
;; Load previously calculated info:
|
||||
(render-time
|
||||
|
|
|
|||
94
collects/syntax/parse/experimental.ss
Normal file
94
collects/syntax/parse/experimental.ss
Normal file
|
|
@ -0,0 +1,94 @@
|
|||
#lang scheme/base
|
||||
(require (for-syntax scheme/base
|
||||
syntax/parse
|
||||
syntax/private/stxparse/rep-data))
|
||||
(provide define-primitive-splicing-syntax-class)
|
||||
|
||||
(define-syntax (define-primitive-splicing-syntax-class stx)
|
||||
|
||||
(define-syntax-class attr
|
||||
(pattern name:id
|
||||
#:with depth #'0)
|
||||
(pattern [name:id depth:nat]))
|
||||
|
||||
(syntax-parse stx
|
||||
[(dssp (name:id param:id ...)
|
||||
(~or (~once (~seq #:attrs (a:attr ...))
|
||||
#:name "attributes declaration")
|
||||
(~once (~seq #:description description)
|
||||
#:name "description declaration")) ...
|
||||
proc:expr)
|
||||
#'(begin
|
||||
(define (get-description param ...)
|
||||
description)
|
||||
(define parser
|
||||
(lambda (stx param ...)
|
||||
(let/ec escape
|
||||
((mk-check-result 'name '(a.name ...) stx)
|
||||
(proc stx
|
||||
(lambda ([msg #f])
|
||||
(escape
|
||||
(if msg
|
||||
`#s(expect:message ,msg)
|
||||
`#s(expect:thing
|
||||
,(get-description param ...) #f #f)))))))))
|
||||
(define-syntax name
|
||||
(make-stxclass 'name '(param ...)
|
||||
'(#s(attr a.name a.depth #f) ...)
|
||||
(quote-syntax parser)
|
||||
(quote-syntax get-description)
|
||||
#t)))]))
|
||||
|
||||
|
||||
(define (mk-check-result name attr-names stx)
|
||||
(lambda (result)
|
||||
(unless (list? result)
|
||||
(error name "parser returned non-list"))
|
||||
(let ([rlength (length result)])
|
||||
(unless (= rlength (+ 2 (length attr-names)))
|
||||
(error name "parser returned list of wrong length; expected length ~s, got ~e"
|
||||
(+ 2 (length attr-names))
|
||||
result))
|
||||
(unless (exact-nonnegative-integer? (cadr result))
|
||||
(error name "expected exact nonnegative integer for second element of result list, got ~e"
|
||||
(cadr result)))
|
||||
(list* (car result)
|
||||
(nat->dfc (cadr result) stx)
|
||||
(cddr result)))))
|
||||
|
||||
(define (nat->dfc nat stx)
|
||||
(if (zero? nat)
|
||||
`#s(dfc:empty ,stx)
|
||||
`#s(dfc:cdr #s(dfc:empty ,stx) ,nat)))
|
||||
|
||||
|
||||
#|
|
||||
|
||||
(define-primitive-splicing-syntax-class (name param ...)
|
||||
#:attrs (attr-decl ...)
|
||||
#:description description-expr
|
||||
proc)
|
||||
|
||||
'proc' must take two arguments, 'stx' and 'fail', where 'fail' is an
|
||||
escaping procedure that indicates failure. 'fail' takes an optional
|
||||
argument, an error message to attach to the failure. If no message is
|
||||
given, the syntax class description is used.
|
||||
|
||||
'proc' must return a list of 2+|attrs| elements. The first element is
|
||||
the rest of the input syntax. The second element is the number of
|
||||
elements consumed from the input. The rest are the attribute values,
|
||||
in the same order as given in the #:attrs directive.
|
||||
|
||||
Example:
|
||||
|
||||
(define-primitive-splicing-syntax-class (a-expr)
|
||||
#:attrs (x)
|
||||
#:description "a-expr"
|
||||
(lambda (stx fail)
|
||||
(syntax-case stx ()
|
||||
[(a b c . rest)
|
||||
(list #'rest 3 #'(printf "got an A\n"))]
|
||||
[_
|
||||
(fail)])))
|
||||
|
||||
|#
|
||||
|
|
@ -1299,6 +1299,7 @@
|
|||
(define mismatch-err (mk-err exn:fail:contract?))
|
||||
|
||||
(define do-sel (lambda (sel n) (for-each (lambda (rb) (sel rb (n rb))) rbs)))
|
||||
(define sel-false (lambda (sel) (do-sel sel (lambda (rb) #f))))
|
||||
(define sel-minus (lambda (sel) (do-sel (type-err sel) (lambda (rb) -1))))
|
||||
(define sel-first (lambda (sel) (do-sel sel (lambda (rb) 0))))
|
||||
(define sel-middle (lambda (sel) (do-sel sel (lambda (rb) (floor (/ (send rb get-number) 2))))))
|
||||
|
|
@ -1311,7 +1312,9 @@
|
|||
(make-object button% (format "Select First~a" title) hp2 (lambda (b e) (sel-first sel)))
|
||||
(make-object button% (format "Select Middle ~a" title) hp2 (lambda (b e) (sel-middle sel)))
|
||||
(make-object button% (format "Select Last~a" title) hp2 (lambda (b e) (sel-last sel)))
|
||||
(make-object button% (format "Select N~a" title) hp2 (lambda (b e) (sel-N sel))))
|
||||
(make-object button% (format "Select N~a" title) hp2 (lambda (b e) (sel-N sel)))
|
||||
(when (equal? title "")
|
||||
(make-object button% (format "Select #f~a" title) hp2 (lambda (b e) (sel-false sel)))))
|
||||
(make-selectors "" normal-sel)
|
||||
(make-selectors " by Simulate" simulate-sel)
|
||||
(make-object button% "Check" p
|
||||
|
|
|
|||
|
|
@ -3,6 +3,8 @@
|
|||
exec mzscheme -qu "$0" ${1+"$@"}
|
||||
|#
|
||||
|
||||
;; See "tabulate.ss" for information on the output format
|
||||
|
||||
(module auto scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
mzlib/process
|
||||
|
|
@ -11,6 +13,8 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
mzlib/compile
|
||||
mzlib/inflate
|
||||
mzlib/date
|
||||
mzlib/port
|
||||
mzlib/file
|
||||
dynext/file
|
||||
syntax/toplevel
|
||||
scheme/runtime-path)
|
||||
|
|
@ -34,10 +38,16 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(delete-file (format "~a.o1" bm)))
|
||||
|
||||
(define (mk-mzscheme bm)
|
||||
;; To get compilation time:
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(namespace-require 'scheme/base)
|
||||
(load (format "~a.ss" bm))))
|
||||
(unless (directory-exists? "compiled")
|
||||
(make-directory "compiled"))
|
||||
(parameterize ([current-namespace (make-base-namespace)]
|
||||
[read-accept-reader #t])
|
||||
(let ([name (format "~a.ss" bm)])
|
||||
(compile-file name
|
||||
(build-path "compiled" (path-add-suffix name #".zo"))))))
|
||||
|
||||
(define (clean-up-zo bm)
|
||||
(delete-directory/files "compiled"))
|
||||
|
||||
(define (clean-up-nothing bm)
|
||||
(void))
|
||||
|
|
@ -71,21 +81,24 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(eval '(define null #f)) ; for dynamic.sch
|
||||
(compile-file (format "~a.sch" bm))))
|
||||
|
||||
(define (clean-up-zo bm)
|
||||
(delete-file (build-path "compiled" (format "~a.zo" bm))))
|
||||
(define (setup-larceny bm)
|
||||
(setup-sps bm "(larceny benchmarking)"))
|
||||
|
||||
(define (mk-larceny bm)
|
||||
(parameterize ([current-input-port
|
||||
(open-input-string
|
||||
(format (string-append
|
||||
"(compiler-switches 'fast-safe)\n"
|
||||
"(compile-file \"~a.sch\")\n")
|
||||
"(import (larceny compiler))\n"
|
||||
"(compile-library \"~a.sls\")\n")
|
||||
bm))]
|
||||
[current-output-port (open-output-bytes)])
|
||||
(system "larceny")))
|
||||
(system "larceny -err5rs")
|
||||
;; Make sure compiled version is used:
|
||||
(delete-file (format "~a.sls" bm))))
|
||||
|
||||
(define (clean-up-fasl bm)
|
||||
(delete-file (format "~a.fasl" bm)))
|
||||
(clean-up-sps bm)
|
||||
(delete-file (format "~a.slfasl" bm)))
|
||||
|
||||
(define (mk-mzc bm)
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
|
|
@ -104,16 +117,45 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(system (format "gsi -:d-,m10000 ~a.o1" bm)))
|
||||
|
||||
(define (run-larceny bm)
|
||||
(parameterize ([current-input-port (open-input-string
|
||||
(format "(load \"~a.fasl\")\n"
|
||||
bm))])
|
||||
(system "larceny")))
|
||||
(system "larceny -r6rs -program prog.sps -path ."))
|
||||
|
||||
(define (setup-sps bm lib)
|
||||
(with-output-to-file "prog.sps"
|
||||
#:exists 'truncate
|
||||
(lambda ()
|
||||
(printf "(import (~a))\n" bm)
|
||||
(printf "(bm-!-go)\n")))
|
||||
(with-output-to-file (format "~a.sls" bm)
|
||||
#:exists 'truncate
|
||||
(lambda ()
|
||||
(printf "(library (~a)\n" bm)
|
||||
(printf " (export bm-!-go)\n")
|
||||
(printf " (import (rnrs) (rnrs mutable-pairs) (rnrs mutable-strings) (rnrs r5rs) (rnrs eval) ~a)\n" lib)
|
||||
(printf " (define (bm-!-go) 'ok)\n")
|
||||
(call-with-input-file (format "~a.sch" bm)
|
||||
(lambda (in)
|
||||
(copy-port in (current-output-port))))
|
||||
(printf ")\n"))))
|
||||
|
||||
(define (clean-up-sps bm)
|
||||
(delete-file "prog.sps")
|
||||
(let ([f (format "~a.sls" bm)])
|
||||
(when (file-exists? f)
|
||||
(delete-file f))))
|
||||
|
||||
(define (setup-ikarus bm)
|
||||
(setup-sps bm "(ikarus)")
|
||||
(system "rm -rf ~/.ikarus"))
|
||||
|
||||
(define (mk-ikarus bm)
|
||||
(void))
|
||||
(system "ikarus --compile-dependencies prog.sps"))
|
||||
|
||||
(define (run-ikarus bm)
|
||||
(system (format "ikarus ~a.sch < /dev/null" bm)))
|
||||
(system "ikarus --r6rs-script prog.sps"))
|
||||
|
||||
(define (clean-up-ikarus bm)
|
||||
(clean-up-sps bm)
|
||||
(system "rm -rf ~/.ikarus"))
|
||||
|
||||
(define (extract-times bm str)
|
||||
str)
|
||||
|
|
@ -134,6 +176,15 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(let ([m (regexp-match #rx#"cpu time: ([0-9]+) real time: ([0-9]+) gc time: ([0-9]+)" str)])
|
||||
(map bytes->number (cdr m))))
|
||||
|
||||
(define (extract-bigloo-times bm str)
|
||||
(let ([m (regexp-match #rx#"real: ([0-9]+) sys: ([0-9]+) user: ([0-9]+)" str)]
|
||||
;; `time' result is 10s of milliseconds? OS ticks, maybe?
|
||||
[msec/tick 10])
|
||||
(list (* msec/tick (+ (bytes->number (caddr m))
|
||||
(bytes->number (cadddr m))))
|
||||
(* msec/tick (bytes->number (cadr m)))
|
||||
0)))
|
||||
|
||||
(define (extract-larceny-times bm str)
|
||||
(let ([m (regexp-match #rx#"Elapsed time...: ([0-9]+) ms.*Elapsed GC time: ([0-9]+) ms" str)])
|
||||
(list (bytes->number (cadr m))
|
||||
|
|
@ -162,14 +213,16 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
#"([0-9]*) ms elapsed cpu time, including ([0-9]*) ms collecting\n"
|
||||
#"[ \t]*([0-9]*) ms elapsed real time")
|
||||
str)])
|
||||
(list (string->number (bytes->string/utf-8 (cadr m)))
|
||||
(string->number (bytes->string/utf-8 (cadddr m)))
|
||||
(string->number (bytes->string/utf-8 (caddr m))))))
|
||||
(if m
|
||||
(list (string->number (bytes->string/utf-8 (cadr m)))
|
||||
(string->number (bytes->string/utf-8 (cadddr m)))
|
||||
(string->number (bytes->string/utf-8 (caddr m))))
|
||||
(list #f #f #f))))
|
||||
|
||||
|
||||
;; Table of implementatons and benchmarks ------------------------------
|
||||
|
||||
(define-struct impl (name make run extract-result clean-up skips))
|
||||
(define-struct impl (name setup make run extract-result clean-up skips))
|
||||
|
||||
(define mutable-pair-progs '(conform
|
||||
destruct
|
||||
|
|
@ -183,34 +236,39 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(define impls
|
||||
(list
|
||||
(make-impl 'mzscheme
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mzscheme -u ~a.ss" bm)))
|
||||
extract-mzscheme-times
|
||||
clean-up-nothing
|
||||
clean-up-zo
|
||||
mutable-pair-progs)
|
||||
(make-impl 'mz-old
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mz-old -u ~a.ss" bm)))
|
||||
extract-mzscheme-times
|
||||
clean-up-nothing
|
||||
clean-up-zo
|
||||
mutable-pair-progs)
|
||||
(make-impl 'mzschemecgc
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mzschemecgc -u ~a.ss" bm)))
|
||||
extract-mzscheme-times
|
||||
clean-up-nothing
|
||||
clean-up-zo
|
||||
mutable-pair-progs)
|
||||
(make-impl 'mzscheme3m
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mzscheme3m -u ~a.ss" bm)))
|
||||
extract-mzscheme-times
|
||||
clean-up-nothing
|
||||
clean-up-zo
|
||||
mutable-pair-progs)
|
||||
(make-impl 'plt-r5rs
|
||||
void
|
||||
mk-plt-r5rs
|
||||
(lambda (bm)
|
||||
(system (format "plt-r5rs ~a.scm" bm)))
|
||||
|
|
@ -218,6 +276,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
clean-up-plt-r5rs
|
||||
null)
|
||||
(make-impl 'mzc
|
||||
void
|
||||
mk-mzc
|
||||
(lambda (bm)
|
||||
(system (format "mzscheme -mvqee '(load-extension \"~a\")' '(require ~a)'"
|
||||
|
|
@ -228,20 +287,23 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(append '(takr takr2)
|
||||
mutable-pair-progs))
|
||||
(make-impl 'mzscheme-j
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mzscheme -jqu ~a.ss" bm)))
|
||||
extract-mzscheme-times
|
||||
clean-up-nothing
|
||||
clean-up-zo
|
||||
mutable-pair-progs)
|
||||
(make-impl 'mzschemecgc-j
|
||||
void
|
||||
mk-mzscheme
|
||||
(lambda (bm)
|
||||
(system (format "mzschemecgc -jqu ~a.ss" bm)))
|
||||
extract-mzscheme-times
|
||||
clean-up-nothing
|
||||
clean-up-zo
|
||||
mutable-pair-progs)
|
||||
(make-impl 'mzschemecgc-tl
|
||||
void
|
||||
mk-mzscheme-tl
|
||||
(lambda (bm)
|
||||
(system (format "mzschemecgc -qr compiled/~a.zo" bm)))
|
||||
|
|
@ -250,37 +312,42 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
(append '(nucleic2)
|
||||
mutable-pair-progs))
|
||||
(make-impl 'chicken
|
||||
void
|
||||
(run-mk "mk-chicken.ss")
|
||||
run-exe
|
||||
extract-chicken-times
|
||||
clean-up-bin
|
||||
'(nucleic2))
|
||||
'(scheme2 takr2))
|
||||
(make-impl 'bigloo
|
||||
void
|
||||
(run-mk "mk-bigloo.ss")
|
||||
run-exe/time
|
||||
extract-time-times
|
||||
run-exe
|
||||
extract-bigloo-times
|
||||
clean-up-bin
|
||||
'(cpstack maze maze2 puzzle triangle))
|
||||
'(cpstack takr2))
|
||||
(make-impl 'gambit
|
||||
void
|
||||
(run-mk "mk-gambit.ss")
|
||||
run-gambit-exe
|
||||
extract-gambit-times
|
||||
clean-up-o1
|
||||
'(nucleic2))
|
||||
(make-impl 'larceny
|
||||
setup-larceny
|
||||
mk-larceny
|
||||
run-larceny
|
||||
extract-larceny-times
|
||||
clean-up-fasl
|
||||
'())
|
||||
(make-impl 'ikarus
|
||||
setup-ikarus
|
||||
mk-ikarus
|
||||
run-ikarus
|
||||
extract-ikarus-times
|
||||
clean-up-nothing
|
||||
'(fft))))
|
||||
clean-up-ikarus
|
||||
'(takr))))
|
||||
|
||||
(define obsolte-impls '(mzscheme mzscheme-j mzschemecgc-tl mzc mz-old))
|
||||
(define obsolte-impls '(mzscheme3m mzschemecgc mzscheme-j mzschemecgc-j mzschemecgc-tl mzc mz-old))
|
||||
|
||||
(define benchmarks
|
||||
'(conform
|
||||
|
|
@ -303,6 +370,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
nboyer
|
||||
nestedloop
|
||||
nfa
|
||||
nothing
|
||||
nqueens
|
||||
nucleic2
|
||||
paraffins
|
||||
|
|
@ -329,23 +397,25 @@ exec mzscheme -qu "$0" ${1+"$@"}
|
|||
impls)])
|
||||
(if (memq bm (impl-skips i))
|
||||
(rprintf "[~a ~a ~s #f]\n" impl bm '(#f #f #f))
|
||||
(let ([start (current-inexact-milliseconds)])
|
||||
((impl-make i) bm)
|
||||
(let ([end (current-inexact-milliseconds)])
|
||||
(let loop ([n num-iterations])
|
||||
(unless (zero? n)
|
||||
(let ([out (open-output-bytes)])
|
||||
(unless (parameterize ([current-output-port out]
|
||||
[current-error-port out])
|
||||
((impl-run i) bm))
|
||||
(error 'auto "~a\nrun failed ~a" (get-output-bytes out) bm))
|
||||
(rprintf "[~a ~a ~s ~a]\n"
|
||||
impl
|
||||
bm
|
||||
((impl-extract-result i) bm (get-output-bytes out))
|
||||
(inexact->exact (round (- end start)))))
|
||||
(loop (sub1 n)))))
|
||||
((impl-clean-up i) bm)))
|
||||
(begin
|
||||
((impl-setup i) bm)
|
||||
(let ([start (current-inexact-milliseconds)])
|
||||
((impl-make i) bm)
|
||||
(let ([end (current-inexact-milliseconds)])
|
||||
(let loop ([n num-iterations])
|
||||
(unless (zero? n)
|
||||
(let ([out (open-output-bytes)])
|
||||
(unless (parameterize ([current-output-port out]
|
||||
[current-error-port out])
|
||||
((impl-run i) bm))
|
||||
(error 'auto "~a\nrun failed ~a" (get-output-bytes out) bm))
|
||||
(rprintf "[~a ~a ~s ~a]\n"
|
||||
impl
|
||||
bm
|
||||
((impl-extract-result i) bm (get-output-bytes out))
|
||||
(inexact->exact (round (- end start)))))
|
||||
(loop (sub1 n)))))
|
||||
((impl-clean-up i) bm))))
|
||||
(flush-output)))
|
||||
|
||||
;; Extract command-line arguments --------------------
|
||||
|
|
|
|||
|
|
@ -1,9 +1,16 @@
|
|||
(define orig-time time)
|
||||
|
||||
(define-macro (time expr)
|
||||
`(time-it (lambda () ,expr)))
|
||||
|
||||
(define (time-it thunk)
|
||||
(thunk))
|
||||
(multiple-value-bind (res rtime stime utime)
|
||||
(orig-time thunk)
|
||||
(print "real: " rtime " sys: " stime " user: " utime)
|
||||
res))
|
||||
|
||||
(define (error . x) #f)
|
||||
|
||||
|
||||
(define bitwise-or bit-or)
|
||||
(define bitwise-and bit-and)
|
||||
(define bitwise-not bit-not)
|
||||
|
|
|
|||
|
|
@ -46,19 +46,13 @@
|
|||
(define (f+dderiv a)
|
||||
(cons '+ (map dderiv a)))
|
||||
|
||||
(put '+ 'dderiv f+dderiv) ; install procedure on the property list
|
||||
|
||||
(define (f-dderiv a)
|
||||
(cons '- (map dderiv a)))
|
||||
|
||||
(put '- 'dderiv f-dderiv) ; install procedure on the property list
|
||||
|
||||
(define (*dderiv a)
|
||||
(list '* (cons '* a)
|
||||
(cons '+ (map dderiv-aux a))))
|
||||
|
||||
(put '* 'dderiv *dderiv) ; install procedure on the property list
|
||||
|
||||
(define (/dderiv a)
|
||||
(list '-
|
||||
(list '/
|
||||
|
|
@ -71,8 +65,6 @@
|
|||
(cadr a)
|
||||
(dderiv (cadr a))))))
|
||||
|
||||
(put '/ 'dderiv /dderiv) ; install procedure on the property list
|
||||
|
||||
(define (dderiv a)
|
||||
(cond
|
||||
((not (pair? a))
|
||||
|
|
@ -90,6 +82,14 @@
|
|||
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
|
||||
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
|
||||
|
||||
(put '+ 'dderiv f+dderiv) ; install procedure on the property list
|
||||
|
||||
(put '- 'dderiv f-dderiv) ; install procedure on the property list
|
||||
|
||||
(put '* 'dderiv *dderiv) ; install procedure on the property list
|
||||
|
||||
(put '/ 'dderiv /dderiv) ; install procedure on the property list
|
||||
|
||||
;;; call: (run)
|
||||
|
||||
(time (run))
|
||||
|
|
|
|||
|
|
@ -5,3 +5,4 @@
|
|||
(safe)
|
||||
(interrupts-enabled)
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -4,45 +4,55 @@
|
|||
|
||||
<H1>About the Benchmarks</H1>
|
||||
|
||||
<p>The pages linked below show some benchmark results on a collection of fairly standard
|
||||
<p>The <a href="Benchmarks.html">benchmark page</a> shows some benchmark results on a collection of fairly standard
|
||||
(mostly Gabriel) Scheme benchmarks.</p>
|
||||
|
||||
<p>Tables show relative performance, with the actual time for the fastest
|
||||
run shown on the left. So, by default, <font color=forestgreen><b>1</b></font>
|
||||
is the fastest, but select any implementation to normalize the table with
|
||||
respect to that implementation's speed. A <tt>--</tt> appears when a benchmark
|
||||
didn't run in an implementation (and you should assume a benchmark problem,
|
||||
rather than an implementation problem).</p>
|
||||
<p>Tables show relative performance, with the actual time for the
|
||||
fastest run shown on the left. So, by
|
||||
default, <font color=forestgreen><b>1</b></font> is the fastest,
|
||||
but select any implementation to normalize the table with respect
|
||||
to that implementation's speed. A <tt>-</tt> appears when a
|
||||
benchmark didn't run in an implementation for some reason (possibly
|
||||
not a good one).</p>
|
||||
|
||||
<p><font color="gray" size="-1">Small gray numbers are (relative) compile times.</font></p>
|
||||
<p><font color="gray" size="-1">Small gray numbers are (relative)
|
||||
compile times, where the compile time for the <tt>nothing</tt>
|
||||
benchmark is subtracted from every other benchmark's compile
|
||||
time.</font></p>
|
||||
|
||||
<p>Run times are averaged over three runs. All reported times are CPU time (system plus user).
|
||||
Where available, the times are based on the output of the implementation's <tt>time</tt>
|
||||
syntactic form, otherwise <tt>/usr/bin/time</tt> is used.</p>
|
||||
The times are based on the output of the implementation's <tt>time</tt>
|
||||
syntactic form for function.</p>
|
||||
|
||||
<p>Compiler configuration:
|
||||
<p>Machine:
|
||||
<ul>
|
||||
<li> Bigloo (2.8b): <tt>-06 -copt -O3 -copt -fomit-frame-pointer</tt></il>
|
||||
<li> Chicken (2 build 3): <tt>-no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift</tt></il>
|
||||
<li> Gambit (4.0 beta 17): <tt>(declare (block) (standard-bindings) (extended-bindings) (safe) (interrupts-enabled))</tt>,
|
||||
installed with <tt>--enable-single-host</tt>, compiled with <tt>-dynamic</tt>, compiled and run with <tt>-:m10000</tt></li>
|
||||
<li> Larceny (0.92b): default mode — but should use <tt>(benchmark-block-mode #t)</tt> when it works</li>
|
||||
<li> MzScheme (352.5): in <tt>module</tt></li>
|
||||
<li> MacBook Pro, 2.53 GHz, Mac OS X 10.6.2, compiling to 32-bit programs
|
||||
</ul></p>
|
||||
|
||||
<p>Compiler configurations:
|
||||
<ul>
|
||||
<li> Bigloo (3.3a): <tt>-06 -call/cc -copt -O3 -copt -fomit-frame-pointer</tt></il>
|
||||
<li> Chicken (4.3.0): <tt>-no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift</tt></il>
|
||||
<li> Gambit (4.6.0): <tt>(declare (block) (standard-bindings) (extended-bindings) (safe) (interrupts-enabled))</tt>,
|
||||
compiled and run with <tt>-:m10000</tt></li>
|
||||
<li> Ikarus (0.0.4-rc1+ rev 1870): in R6RS library</li>
|
||||
<li> Larceny (0.97): in R6RS library</li>
|
||||
<li> PLT (4.2.4): in <tt>module</tt>; for benchmarks that use <tt>set-car!</tt> and <tt>set-cdr!</tt>,
|
||||
PLT's R5RS support is used</li>
|
||||
</ul>
|
||||
These configurations are all "safe mode", but they allow the compiler
|
||||
to assume that built-in Scheme functions are not redefined and (except
|
||||
in the case of Larceny) that no top-level defintion is ever
|
||||
These configurations are all “safe mode,” but they allow the compiler
|
||||
to assume that built-in Scheme functions are not redefined and that no top-level defintion is ever
|
||||
changed. Such assumptions correspond to putting the benchmark in an
|
||||
R6RS library (we expect).</P>
|
||||
R6RS library.</P>
|
||||
|
||||
<p>In general, we attempt to use the various implementations in a compentent way,
|
||||
but not in a sophisticated way. For example, we do not tweak
|
||||
inlining parameters or specify fixnum arithmetic (where appropriate),
|
||||
which could produce significant improvements from some compilers.</p>
|
||||
|
||||
<p>For a larger set of benchmarks and a more sophisticated use of the compilers,
|
||||
see Marc Feeley's page:
|
||||
<a href="http://www.iro.umontreal.ca/~gambit/bench.html">http://www.iro.umontreal.ca/~gambit/bench.html</a>.
|
||||
<p>For more benchmarks and a more sophisticated use of a few compilers,
|
||||
including fixnum- and flonum-specific arithmetic as well as unsafe modes,
|
||||
see <a href="../log1/Gambit_20benchmarks.html">this other page</a>.</p>
|
||||
|
||||
<p>For further details on the benchmarks here, see the benchmark source and
|
||||
infrastructure, which is available form the PLT SVN repository:</p>
|
||||
|
|
@ -50,8 +60,3 @@ R6RS library (we expect).</P>
|
|||
<p align=center>
|
||||
<a href="http://svn.plt-scheme.org/plt/trunk/collects/tests/mzscheme/benchmarks/common/">http://svn.plt-scheme.org/plt/trunk/collects/tests/mzscheme/benchmarks/common/</a></P>
|
||||
|
||||
<H1>Results</H1>
|
||||
|
||||
<ul>
|
||||
<li> <a href=machine1.html>machine1</a> ...
|
||||
</ul>
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -9,9 +9,9 @@
|
|||
(include "bigloo-prelude.sch")
|
||||
(include ,(format "~a.sch" name))))
|
||||
(newline))
|
||||
'truncate/replace)
|
||||
#:exists 'truncate/replace)
|
||||
|
||||
(when (system (format "bigloo -w -o ~a -copt -O3 -copt -fomit-frame-pointer -O6 ~a~a.scm"
|
||||
(when (system (format "bigloo -w -o ~a -copt -m32 -call/cc -copt -O3 -copt -fomit-frame-pointer -O6 ~a~a.scm"
|
||||
name
|
||||
(if (memq (string->symbol name)
|
||||
'(ctak))
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@
|
|||
'fail))
|
||||
|
||||
(time (let ((input (string->list (string-append (make-string 133 #\a) "bc"))))
|
||||
(let loop ((n 50000))
|
||||
(let loop ((n 150000))
|
||||
(if (zero? n)
|
||||
'done
|
||||
(begin
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user