1288 lines
57 KiB
Racket
1288 lines
57 KiB
Racket
#lang racket/unit
|
|
|
|
(require "drsig.rkt"
|
|
string-constants
|
|
|
|
;; NOTE: this module instantiates stacktrace itself, so we have
|
|
;; to be careful to not mix that instantiation with the one
|
|
;; drracket/private/debug.rkt does. errortrace-lib's is for the
|
|
;; compilation handling, DrRacket's is for profiling and test coverage
|
|
;; (which do not do compilation)
|
|
(prefix-in el: errortrace/errortrace-lib)
|
|
|
|
(prefix-in image-core: mrlib/image-core)
|
|
|
|
mzlib/pconvert
|
|
racket/pretty
|
|
mzlib/struct
|
|
racket/class
|
|
racket/file
|
|
racket/list
|
|
compiler/embed
|
|
launcher
|
|
mred
|
|
framework
|
|
mrlib/syntax-browser
|
|
compiler/distribute
|
|
compiler/bundle-dist
|
|
"rep.rkt")
|
|
|
|
(import [prefix drracket:debug: drracket:debug^]
|
|
[prefix drracket:tools: drracket:tools^]
|
|
[prefix drracket:rep: drracket:rep^]
|
|
[prefix drracket:help-desk: drracket:help-desk^])
|
|
(export drracket:language^)
|
|
|
|
(define original-output-port (current-output-port))
|
|
(define (oprintf . args) (apply fprintf original-output-port args))
|
|
|
|
(define-struct text/pos (text start end))
|
|
;; text/pos = (make-text/pos (instanceof text% number number))
|
|
;; this represents a portion of a text to be processed.
|
|
|
|
(define language<%>
|
|
(interface ()
|
|
marshall-settings
|
|
unmarshall-settings
|
|
default-settings
|
|
default-settings?
|
|
|
|
front-end/complete-program
|
|
front-end/finished-complete-program
|
|
front-end/interaction
|
|
config-panel
|
|
on-execute
|
|
extra-repl-information
|
|
|
|
first-opened
|
|
render-value/format
|
|
render-value
|
|
|
|
capability-value
|
|
|
|
create-executable
|
|
|
|
get-reader-module
|
|
get-metadata
|
|
metadata->settings
|
|
get-metadata-lines
|
|
|
|
get-language-position
|
|
get-language-name
|
|
get-style-delta
|
|
get-language-numbers
|
|
get-one-line-summary
|
|
get-language-url
|
|
get-comment-character))
|
|
|
|
(define module-based-language<%>
|
|
(interface ()
|
|
marshall-settings
|
|
unmarshall-settings
|
|
default-settings
|
|
default-settings?
|
|
|
|
get-module
|
|
get-transformer-module
|
|
use-namespace-require/copy?
|
|
use-namespace-require/copy-from-setting?
|
|
config-panel
|
|
|
|
get-reader
|
|
|
|
on-execute
|
|
get-init-code
|
|
use-mred-launcher
|
|
|
|
render-value/format
|
|
render-value
|
|
|
|
get-language-position
|
|
get-language-numbers
|
|
get-one-line-summary
|
|
get-language-url))
|
|
|
|
(define simple-module-based-language<%>
|
|
(interface ()
|
|
get-module
|
|
get-language-position
|
|
get-language-numbers
|
|
get-one-line-summary
|
|
get-language-url
|
|
get-reader))
|
|
|
|
|
|
(define simple-module-based-language%
|
|
(class* object% (simple-module-based-language<%>)
|
|
(init-field module
|
|
language-position
|
|
(language-numbers (map (λ (x) 0) language-position))
|
|
(one-line-summary "")
|
|
(language-url #f)
|
|
(documentation-reference #f)
|
|
(reader (λ (src port)
|
|
(let ([v (parameterize ([read-accept-reader #t])
|
|
(with-stack-checkpoint
|
|
(read-syntax src port)))])
|
|
(if (eof-object? v)
|
|
v
|
|
(namespace-syntax-introduce v)))))
|
|
(language-id (if (pair? language-position)
|
|
(car (last-pair language-position))
|
|
(error 'simple-module-based-language<%>
|
|
"expected non-empty list of strings, got ~e" language-position))))
|
|
(define/public (get-module) module)
|
|
(define/public (get-language-position) language-position)
|
|
(define/public (get-language-numbers) language-numbers)
|
|
(define/public (get-one-line-summary) one-line-summary)
|
|
(define/public (get-language-url) language-url)
|
|
(define/public (get-reader) reader)
|
|
(super-instantiate ())))
|
|
|
|
|
|
|
|
;; simple-module-based-language->module-based-language : module-based-language<%>
|
|
;; transforms a simple-module-based-language into a module-based-language<%>
|
|
(define simple-module-based-language->module-based-language-mixin
|
|
(mixin (simple-module-based-language<%>) (module-based-language<%>)
|
|
(define/public (get-transformer-module) 'mzscheme)
|
|
(define/public (use-namespace-require/copy?) #f)
|
|
(define/public (use-namespace-require/copy-from-setting? setting)
|
|
(use-namespace-require/copy?))
|
|
(define/public (use-mred-launcher) #t)
|
|
|
|
(inherit get-module)
|
|
(define/public (marshall-settings settings)
|
|
(simple-settings->vector settings))
|
|
(define/public (unmarshall-settings printable)
|
|
(and (vector? printable)
|
|
(= (vector-length printable)
|
|
(procedure-arity make-simple-settings))
|
|
(boolean? (vector-ref printable 0))
|
|
(memq (vector-ref printable 1) '(constructor quasiquote write trad-write print))
|
|
(memq (vector-ref printable 2)
|
|
'(mixed-fraction
|
|
mixed-fraction-e
|
|
repeating-decimal
|
|
repeating-decimal-e))
|
|
(boolean? (vector-ref printable 3))
|
|
(boolean? (vector-ref printable 4))
|
|
(memq (vector-ref printable 5) '(none debug debug/profile test-coverage))
|
|
(apply make-simple-settings (vector->list printable))))
|
|
(define/public (default-settings)
|
|
(make-simple-settings #t 'print 'mixed-fraction-e #f #t 'debug))
|
|
(define/public (default-settings? x)
|
|
(equal? (simple-settings->vector x)
|
|
(simple-settings->vector (default-settings))))
|
|
(define/public (config-panel parent)
|
|
(simple-module-based-language-config-panel parent))
|
|
|
|
(define/public (on-execute setting run-in-user-thread)
|
|
(initialize-simple-module-based-language setting run-in-user-thread))
|
|
(define/public (get-init-code setting)
|
|
(simple-module-based-language-get-init-code setting))
|
|
|
|
(define/public (render-value/format value settings port width)
|
|
(simple-module-based-language-render-value/format value settings port width))
|
|
(define/public (render-value value settings port)
|
|
(simple-module-based-language-render-value/format value settings port 'infinity))
|
|
(super-instantiate ())))
|
|
|
|
;; settings for a simple module based language
|
|
(define-struct simple-settings (case-sensitive
|
|
printing-style
|
|
fraction-style
|
|
show-sharing
|
|
insert-newlines
|
|
annotations))
|
|
;; case-sensitive : boolean
|
|
;; printing-style : (union 'print 'write 'trad-write 'constructor 'quasiquote)
|
|
;; fraction-style : (union 'mixed-fraction 'mixed-fraction-e 'repeating-decimal 'repeating-decimal-e)
|
|
;; show-sharing : boolean
|
|
;; insert-newlines : boolean
|
|
;; annotations : (union 'none 'debug 'debug/profile 'test-coverage)
|
|
(define simple-settings->vector (make-->vector simple-settings))
|
|
|
|
;; simple-module-based-language-config-panel :
|
|
;; parent [#:case-sensitive (union #f #t '?)]
|
|
;; -> (case-> (-> settings) (settings -> void))
|
|
(define (simple-module-based-language-config-panel
|
|
_parent
|
|
#:case-sensitive [*case-sensitive '?]
|
|
#:dynamic-panel-extras [dynamic-panel-extras void]
|
|
#:get-debugging-radio-box [get-debugging-radio-box void]
|
|
#:debugging-radio-box-callback [debugging-radio-box-callback void])
|
|
(letrec ([parent (instantiate vertical-panel% ()
|
|
(parent _parent)
|
|
(alignment '(center center)))]
|
|
|
|
[input-panel (and (eq? *case-sensitive '?)
|
|
(instantiate group-box-panel% ()
|
|
(label (string-constant input-syntax))
|
|
(parent parent)
|
|
(alignment '(left center))))]
|
|
|
|
[dynamic-panel (instantiate group-box-panel% ()
|
|
(label (string-constant dynamic-properties))
|
|
(parent parent)
|
|
(alignment '(left center)))]
|
|
|
|
[output-panel (instantiate group-box-panel% ()
|
|
(label (string-constant output-syntax))
|
|
(parent parent)
|
|
(alignment '(left center)))]
|
|
|
|
[case-sensitive (and input-panel
|
|
(make-object check-box%
|
|
(string-constant case-sensitive-label)
|
|
input-panel
|
|
void))]
|
|
[debugging-panel (new horizontal-panel%
|
|
[parent dynamic-panel]
|
|
[stretchable-height #f]
|
|
[alignment '(left center)])]
|
|
[debugging-left (new radio-box%
|
|
(label #f)
|
|
(choices
|
|
(list (string-constant no-debugging-or-profiling)
|
|
(string-constant debugging)))
|
|
(parent debugging-panel)
|
|
(callback
|
|
(λ (a b)
|
|
(send debugging-right set-selection #f)
|
|
(debugging-radio-box-callback a b))))]
|
|
[debugging-right (new radio-box%
|
|
(label #f)
|
|
(choices
|
|
(list (string-constant debugging-and-profiling)
|
|
(string-constant test-coverage)))
|
|
(parent debugging-panel)
|
|
(callback
|
|
(λ (a b)
|
|
(send debugging-left set-selection #f)
|
|
(debugging-radio-box-callback a b))))]
|
|
[output-style (make-object radio-box%
|
|
(string-constant output-style-label)
|
|
(list (string-constant constructor-printing-style)
|
|
(string-constant quasiquote-printing-style)
|
|
(string-constant write-printing-style)
|
|
(string-constant print-printing-style))
|
|
output-panel
|
|
(λ (rb evt) (enable-fraction-style))
|
|
'(horizontal vertical-label))]
|
|
[enable-fraction-style
|
|
(lambda ()
|
|
(let ([on? (member (send output-style get-selection) '(0 1))])
|
|
(send fraction-style enable on?)))]
|
|
[show-sharing (make-object check-box%
|
|
(string-constant sharing-printing-label)
|
|
output-panel
|
|
void)]
|
|
[insert-newlines (make-object check-box%
|
|
(string-constant use-pretty-printer-label)
|
|
output-panel
|
|
void)]
|
|
[fraction-style
|
|
(make-object check-box% (string-constant decimal-notation-for-rationals)
|
|
output-panel
|
|
void)])
|
|
(get-debugging-radio-box debugging-left debugging-right)
|
|
(dynamic-panel-extras dynamic-panel)
|
|
|
|
(case-lambda
|
|
[()
|
|
(make-simple-settings
|
|
(if case-sensitive
|
|
(send case-sensitive get-value)
|
|
(and *case-sensitive #t))
|
|
(case (send output-style get-selection)
|
|
[(0) 'constructor]
|
|
[(1) 'quasiquote]
|
|
[(2) 'trad-write]
|
|
[(3) 'print])
|
|
(if (send fraction-style get-value)
|
|
'repeating-decimal-e
|
|
'mixed-fraction-e)
|
|
(send show-sharing get-value)
|
|
(send insert-newlines get-value)
|
|
(case (send debugging-left get-selection)
|
|
[(0) 'none]
|
|
[(1) 'debug]
|
|
[(#f)
|
|
(case (send debugging-right get-selection)
|
|
[(0) 'debug/profile]
|
|
[(1) 'test-coverage])]))]
|
|
[(settings)
|
|
(when case-sensitive
|
|
(send case-sensitive set-value
|
|
(simple-settings-case-sensitive settings)))
|
|
(send output-style set-selection
|
|
(case (simple-settings-printing-style settings)
|
|
[(constructor) 0]
|
|
[(quasiquote) 1]
|
|
[(write trad-write) 2]
|
|
[(print) 3]))
|
|
(enable-fraction-style)
|
|
(send fraction-style set-value (eq? (simple-settings-fraction-style settings)
|
|
'repeating-decimal-e))
|
|
(send show-sharing set-value (simple-settings-show-sharing settings))
|
|
(send insert-newlines set-value (simple-settings-insert-newlines settings))
|
|
(case (simple-settings-annotations settings)
|
|
[(none) (send debugging-right set-selection #f) (send debugging-left set-selection 0)]
|
|
[(debug) (send debugging-right set-selection #f) (send debugging-left set-selection 1)]
|
|
[(debug/profile) (send debugging-left set-selection #f) (send debugging-right set-selection 0)]
|
|
[(test-coverage) (send debugging-left set-selection #f) (send debugging-right set-selection 1)])])))
|
|
|
|
;; simple-module-based-language-render-value/format : TST settings port (union #f (snip% -> void)) (union 'infinity number) -> void
|
|
(define (simple-module-based-language-render-value/format value settings port width)
|
|
(let-values ([(converted-value write?)
|
|
(call-with-values
|
|
(lambda ()
|
|
(simple-module-based-language-convert-value value settings))
|
|
(case-lambda
|
|
[(converted-value) (values converted-value #t)]
|
|
[(converted-value write?) (values converted-value write?)]))])
|
|
(let ([pretty-out (if write? pretty-write pretty-print)])
|
|
(setup-printing-parameters
|
|
(λ ()
|
|
(cond
|
|
[(simple-settings-insert-newlines settings)
|
|
(if (number? width)
|
|
(parameterize ([pretty-print-columns width])
|
|
(pretty-out converted-value port))
|
|
(pretty-out converted-value port))]
|
|
[else
|
|
(parameterize ([pretty-print-columns 'infinity])
|
|
(pretty-out converted-value port))
|
|
(newline port)]))
|
|
settings
|
|
width))))
|
|
|
|
(define default-pretty-print-current-style-table (pretty-print-current-style-table))
|
|
|
|
;; setup-printing-parameters : (-> void) simple-settings number -> void
|
|
(define (setup-printing-parameters thunk settings width)
|
|
(let ([use-number-snip?
|
|
(λ (x)
|
|
(and (number? x)
|
|
(exact? x)
|
|
(real? x)
|
|
(not (integer? x))))])
|
|
(parameterize (
|
|
;; these three handlers aren't used, but are set to override the user's settings
|
|
[pretty-print-print-line (λ (line-number op old-line dest-columns)
|
|
(when (and (not (equal? line-number 0))
|
|
(not (equal? dest-columns 'infinity)))
|
|
(newline op))
|
|
0)]
|
|
[pretty-print-pre-print-hook (λ (val port) (void))]
|
|
[pretty-print-post-print-hook (λ (val port) (void))]
|
|
[pretty-print-exact-as-decimal #f]
|
|
[pretty-print-depth #f]
|
|
[pretty-print-.-symbol-without-bars #f]
|
|
[pretty-print-show-inexactness #f]
|
|
[pretty-print-abbreviate-read-macros #t]
|
|
[pretty-print-current-style-table default-pretty-print-current-style-table]
|
|
[pretty-print-remap-stylable (λ (x) #f)]
|
|
[pretty-print-print-line
|
|
(lambda (line port offset width)
|
|
(when (and (number? width)
|
|
(not (eq? 0 line)))
|
|
(newline port))
|
|
0)]
|
|
|
|
[pretty-print-columns width]
|
|
[pretty-print-size-hook
|
|
(λ (value display? port)
|
|
(cond
|
|
[(not (port-writes-special? port)) #f]
|
|
[(is-a? value snip%) 1]
|
|
[(use-number-snip? value) 1]
|
|
[(syntax? value) 1]
|
|
[(to-snip-value? value) 1]
|
|
[else #f]))]
|
|
[pretty-print-print-hook
|
|
(λ (value display? port)
|
|
(cond
|
|
[(image-core:image? value)
|
|
|
|
;; do this computation here so that any failures
|
|
;; during drawing happen under the user's custodian
|
|
(image-core:compute-image-cache value)
|
|
|
|
(write-special value port)
|
|
1]
|
|
[(is-a? value snip%)
|
|
(write-special value port)
|
|
1]
|
|
[(use-number-snip? value)
|
|
(write-special
|
|
(case (simple-settings-fraction-style settings)
|
|
[(mixed-fraction)
|
|
(number-snip:make-fraction-snip value #f)]
|
|
[(mixed-fraction-e)
|
|
(number-snip:make-fraction-snip value #t)]
|
|
[(repeating-decimal)
|
|
(number-snip:make-repeating-decimal-snip value #f)]
|
|
[(repeating-decimal-e)
|
|
(number-snip:make-repeating-decimal-snip value #t)])
|
|
port)
|
|
1]
|
|
[(syntax? value)
|
|
(write-special (render-syntax/snip value) port)]
|
|
[else (write-special (value->snip value) port)]))]
|
|
[print-graph
|
|
;; only turn on print-graph when using `write' or `print' printing
|
|
;; style, because the sharing is being taken care of
|
|
;; by the print-convert sexp construction when using
|
|
;; other printing styles.
|
|
(and (memq (simple-settings-printing-style settings) '(write print))
|
|
(simple-settings-show-sharing settings))])
|
|
(thunk))))
|
|
|
|
;; drscheme-inspector : inspector
|
|
(define drscheme-inspector (current-inspector))
|
|
|
|
;; simple-module-based-language-convert-value : TST settings -> TST
|
|
(define (simple-module-based-language-convert-value value settings)
|
|
(case (simple-settings-printing-style settings)
|
|
[(print) (values value #f)]
|
|
[(write trad-write) value]
|
|
[(constructor)
|
|
(parameterize ([constructor-style-printing #t]
|
|
[show-sharing (simple-settings-show-sharing settings)]
|
|
[current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))])
|
|
(print-convert value))]
|
|
[(quasiquote)
|
|
(parameterize ([constructor-style-printing #f]
|
|
[show-sharing (simple-settings-show-sharing settings)]
|
|
[current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))])
|
|
(print-convert value))]))
|
|
|
|
;; leave-snips-alone-hook : any? (any? -> printable) any? -> printable
|
|
(define ((leave-snips-alone-hook sh) expr basic-convert sub-convert)
|
|
(if (or (is-a? expr snip%)
|
|
(to-snip-value? expr))
|
|
expr
|
|
(sh expr basic-convert sub-convert)))
|
|
|
|
;; initialize-simple-module-based-language : setting ((-> void) -> void)
|
|
(define (initialize-simple-module-based-language setting run-in-user-thread)
|
|
(run-in-user-thread
|
|
(λ ()
|
|
|
|
(let ([annotations (simple-settings-annotations setting)])
|
|
(case annotations
|
|
[(debug)
|
|
(current-compile (el:make-errortrace-compile-handler))
|
|
(error-display-handler
|
|
(drracket:debug:make-debug-error-display-handler
|
|
(error-display-handler)))
|
|
(use-compiled-file-paths
|
|
(cons (build-path "compiled" "errortrace")
|
|
(use-compiled-file-paths)))]
|
|
|
|
[(debug/profile)
|
|
(drracket:debug:profiling-enabled #t)
|
|
(error-display-handler
|
|
(drracket:debug:make-debug-error-display-handler
|
|
(error-display-handler)))
|
|
(current-eval (drracket:debug:make-debug-eval-handler (current-eval)))]
|
|
|
|
[(debug/profile test-coverage)
|
|
(drracket:debug:test-coverage-enabled #t)
|
|
(current-eval (drracket:debug:make-debug-eval-handler (current-eval)))]))
|
|
|
|
(global-port-print-handler
|
|
(λ (value port [depth 0])
|
|
(let-values ([(converted-value write?)
|
|
(call-with-values
|
|
(lambda () (simple-module-based-language-convert-value value setting))
|
|
(case-lambda
|
|
[(converted-value) (values converted-value #t)]
|
|
[(converted-value write?) (values converted-value write?)]))])
|
|
(setup-printing-parameters
|
|
(λ ()
|
|
(parameterize ([pretty-print-columns 'infinity])
|
|
((if write? pretty-write pretty-print) converted-value port)))
|
|
setting
|
|
'infinity))))
|
|
(current-inspector (make-inspector))
|
|
(read-case-sensitive (simple-settings-case-sensitive setting)))))
|
|
|
|
;; simple-module-based-language-get-init-code : setting -> sexp[module]
|
|
(define (simple-module-based-language-get-init-code setting)
|
|
`(module mod-name mzscheme
|
|
(require mzlib/pconvert
|
|
mzlib/pretty)
|
|
|
|
(provide init-code)
|
|
|
|
(define (executable-error-value->string-handler val size)
|
|
(let ([o (open-output-string)])
|
|
(render-value val o)
|
|
(let ([s (get-output-string o)])
|
|
(if ((string-length s) . <= . size)
|
|
s
|
|
(string-append
|
|
(substring s 0 (- size 3))
|
|
"...")))))
|
|
|
|
(define (render-value value port)
|
|
(parameterize ([pretty-print-columns 'infinity])
|
|
,(case (simple-settings-printing-style setting)
|
|
[(print) `(pretty-print value port)]
|
|
[(write trad-write) `(pretty-write value port)]
|
|
[(constructor)
|
|
`(parameterize ([constructor-style-printing #t]
|
|
[show-sharing ,(simple-settings-show-sharing setting)])
|
|
(pretty-write (print-convert value) port))]
|
|
[(quasiquote)
|
|
`(parameterize ([constructor-style-printing #f]
|
|
[show-sharing ,(simple-settings-show-sharing setting)])
|
|
(pretty-write (print-convert value) port))])))
|
|
|
|
,(if (memq (simple-settings-annotations setting) '(debug debug/profile test-coverage))
|
|
`(require errortrace)
|
|
`(void))
|
|
|
|
(define (init-code)
|
|
(current-inspector (make-inspector))
|
|
(error-value->string-handler executable-error-value->string-handler)
|
|
(read-case-sensitive ,(simple-settings-case-sensitive setting)))))
|
|
|
|
|
|
;; module-based-language->language : module-based-language -> language<%>
|
|
;; given a module-based-language, implements a language
|
|
(define module-based-language->language-mixin
|
|
(mixin (module-based-language<%>) (language<%>)
|
|
(inherit get-module get-transformer-module use-namespace-require/copy-from-setting?
|
|
get-init-code use-mred-launcher get-reader)
|
|
|
|
(define/public (front-end/finished-complete-program settings) (void))
|
|
(define/public (module-based-language->language-mixin settings) (void))
|
|
|
|
(define/pubment (capability-value s)
|
|
(inner (get-capability-default s) capability-value s))
|
|
|
|
(define/public (first-opened) (void))
|
|
(define/public (get-comment-character) (values "; " #\;))
|
|
|
|
(inherit get-language-position)
|
|
(define/public (get-language-name)
|
|
(let ([pos (get-language-position)])
|
|
(if (null? pos)
|
|
"<<unknown>>"
|
|
(car (last-pair pos)))))
|
|
(define/public (get-style-delta) #f)
|
|
(define/override (on-execute setting run-in-user-thread)
|
|
(super on-execute setting run-in-user-thread)
|
|
(initialize-module-based-language (use-namespace-require/copy-from-setting? setting)
|
|
(get-module)
|
|
(get-transformer-module)
|
|
run-in-user-thread))
|
|
(define/public (front-end/complete-program port settings)
|
|
(module-based-language-front-end port (get-reader)))
|
|
(define/public (front-end/interaction port settings)
|
|
(module-based-language-front-end port (get-reader)))
|
|
(define/public (create-executable setting parent program-filename)
|
|
(create-module-based-language-executable parent
|
|
program-filename
|
|
(get-module)
|
|
(get-transformer-module)
|
|
(get-init-code setting)
|
|
(use-mred-launcher)
|
|
(use-namespace-require/copy-from-setting? setting)))
|
|
(define/public (extra-repl-information _1 _2) (void))
|
|
(define/public (get-reader-module) #f)
|
|
(define/public (get-metadata a b) #f)
|
|
(define/public (metadata->settings m) #f)
|
|
(define/public (get-metadata-lines) #f)
|
|
|
|
(super-new)))
|
|
|
|
;; create-module-based-language-executable :
|
|
;; (is-a?/c area-container<%>) string (or #f module-spec) module-spec sexp (union boolean? 'ask) boolean?
|
|
;; -> void
|
|
(define (create-module-based-language-executable parent
|
|
program-filename
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
mred-launcher
|
|
use-copy?)
|
|
(let ([executable-specs (create-executable-gui parent
|
|
program-filename
|
|
#t
|
|
(if (boolean? mred-launcher)
|
|
(if mred-launcher
|
|
'mred
|
|
'mzscheme)
|
|
#t))])
|
|
(when executable-specs
|
|
(let* ([type (car executable-specs)]
|
|
[base (cadr executable-specs)]
|
|
[executable-filename (caddr executable-specs)]
|
|
[create-executable
|
|
(case type
|
|
[(launcher) create-module-based-launcher]
|
|
[(stand-alone) create-module-based-stand-alone-executable]
|
|
[(distribution) create-module-based-distribution])])
|
|
(create-executable
|
|
program-filename
|
|
executable-filename
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
(if (boolean? mred-launcher)
|
|
mred-launcher
|
|
(eq? base 'mred))
|
|
use-copy?)))))
|
|
|
|
|
|
;; create-executable-gui : (union #f (is-a?/c top-level-area-container<%>))
|
|
;; (union #f string?)
|
|
;; (union #t 'launcher 'stand-alone 'distribution)
|
|
;; (union #t 'mzscheme 'mred)
|
|
;; -> (union #f (list (union 'no-show 'launcher 'stand-alone 'distribution)
|
|
;; (union 'no-show 'mzscheme 'mred)
|
|
;; string[filename]))
|
|
(define (create-executable-gui parent program-filename show-type show-base)
|
|
(define dlg (make-object dialog% (string-constant create-executable-title) parent))
|
|
(define filename-panel (make-object horizontal-panel% dlg))
|
|
(define filename-text-field (new text-field%
|
|
[label (string-constant filename)]
|
|
[parent filename-panel]
|
|
[init-value (path->string
|
|
(default-executable-filename
|
|
program-filename
|
|
(if (eq? show-type #t) 'launcher show-type)
|
|
#f))]
|
|
[min-width 400]
|
|
[callback void]))
|
|
(define filename-browse-button (instantiate button% ()
|
|
(label (string-constant browse...))
|
|
(parent filename-panel)
|
|
(callback
|
|
(λ (x y) (browse-callback)))))
|
|
(define type/base-panel (instantiate vertical-panel% ()
|
|
(parent dlg)
|
|
(stretchable-width #f)))
|
|
(define type-panel (make-object horizontal-panel% type/base-panel))
|
|
(define type-rb (and (boolean? show-type)
|
|
(instantiate radio-box% ()
|
|
(label (string-constant executable-type))
|
|
(choices (list (string-constant launcher-explanatory-label)
|
|
(string-constant stand-alone-explanatory-label)
|
|
(string-constant distribution-explanatory-label)))
|
|
(parent type-panel)
|
|
(callback (lambda (rb e)
|
|
(preferences:set 'drracket:create-executable-gui-type
|
|
(case (send rb get-selection)
|
|
[(0) 'launcher]
|
|
[(1) 'stand-alone]
|
|
[(2) 'distribution]))
|
|
(reset-filename-suffix))))))
|
|
(define base-panel (make-object horizontal-panel% type/base-panel))
|
|
(define base-rb (and (boolean? show-base)
|
|
(instantiate radio-box% ()
|
|
(label (string-constant executable-base))
|
|
(choices (list "Racket" "GRacket"))
|
|
(parent base-panel)
|
|
(callback (lambda (rb e)
|
|
(preferences:set 'drracket:create-executable-gui-base
|
|
(case (send rb get-selection)
|
|
[(0) 'racket]
|
|
[(1) 'gracket]))
|
|
(reset-filename-suffix))))))
|
|
|
|
(define (reset-filename-suffix)
|
|
(let ([s (send filename-text-field get-value)])
|
|
(unless (string=? s "")
|
|
(let ([new-s (default-executable-filename
|
|
(string->path s)
|
|
(current-mode)
|
|
(not (currently-mzscheme-binary?)))])
|
|
(send filename-text-field set-value (path->string new-s))))))
|
|
|
|
(define button-panel (instantiate horizontal-panel% ()
|
|
(parent dlg)
|
|
(alignment '(right center))))
|
|
|
|
(define-values (ok-button cancel-button)
|
|
(gui-utils:ok/cancel-buttons
|
|
button-panel
|
|
(λ (x y)
|
|
(when (check-filename)
|
|
(set! cancelled? #f)
|
|
(send dlg show #f)))
|
|
(λ (x y) (send dlg show #f))
|
|
(string-constant create)
|
|
(string-constant cancel)))
|
|
|
|
(define (browse-callback)
|
|
(let ([ftf (send filename-text-field get-value)])
|
|
(let-values ([(base name _)
|
|
(if (path-string? ftf)
|
|
(split-path ftf)
|
|
(values (current-directory) "" #f))])
|
|
(let* ([mzscheme? (currently-mzscheme-binary?)]
|
|
[mode (current-mode)]
|
|
[filename
|
|
(put-executable/defaults
|
|
dlg
|
|
base
|
|
name
|
|
mode
|
|
(not mzscheme?)
|
|
(case mode
|
|
[(launcher)
|
|
(if mzscheme?
|
|
(string-constant save-a-mzscheme-launcher)
|
|
(string-constant save-a-mred-launcher))]
|
|
[(stand-alone)
|
|
(if mzscheme?
|
|
(string-constant save-a-mzscheme-stand-alone-executable)
|
|
(string-constant save-a-mred-stand-alone-executable))]
|
|
[(distribution)
|
|
(if mzscheme?
|
|
(string-constant save-a-mzscheme-distribution)
|
|
(string-constant save-a-mred-distribution))]))])
|
|
(when filename
|
|
(send filename-text-field set-value (path->string filename)))))))
|
|
|
|
(define (currently-mzscheme-binary?)
|
|
(cond
|
|
[base-rb
|
|
(= 0 (send base-rb get-selection))]
|
|
[else (eq? show-base 'mzscheme)]))
|
|
|
|
(define (current-mode)
|
|
(cond
|
|
[type-rb
|
|
(let ([s (send type-rb get-item-label (send type-rb get-selection))])
|
|
(cond
|
|
[(equal? s (string-constant launcher-explanatory-label)) 'launcher]
|
|
[(equal? s (string-constant stand-alone-explanatory-label)) 'stand-alone]
|
|
[(equal? s (string-constant distribution-explanatory-label)) 'distribution]))]
|
|
[else show-type]))
|
|
|
|
(define (check-filename)
|
|
(let ([filename-str (send filename-text-field get-value)]
|
|
[mred? (not (currently-mzscheme-binary?))]
|
|
[mode (current-mode)])
|
|
(let-values ([(extension style filters)
|
|
(mode->put-file-extension+style+filters mode mred?)])
|
|
(cond
|
|
[(string=? "" filename-str)
|
|
(message-box (string-constant drscheme)
|
|
(string-constant please-specify-a-filename)
|
|
dlg)
|
|
#f]
|
|
[(not (users-name-ok? mode extension dlg (string->path filename-str)))
|
|
#f]
|
|
[(or (directory-exists? filename-str)
|
|
(file-exists? filename-str))
|
|
(ask-user-can-clobber? filename-str)]
|
|
[else #t]))))
|
|
|
|
;; ask-user-can-clobber-directory? : (is-a?/c top-level-window<%>) string -> boolean
|
|
(define (ask-user-can-clobber? filename)
|
|
(eq? (message-box (string-constant drscheme)
|
|
(format (string-constant are-you-sure-delete?) filename)
|
|
dlg
|
|
'(yes-no))
|
|
'yes))
|
|
|
|
(define cancelled? #t)
|
|
(when type-rb
|
|
(send type-rb set-selection
|
|
(case (preferences:get 'drracket:create-executable-gui-type)
|
|
[(launcher) 0]
|
|
[(stand-alone) 1]
|
|
[(distribution) 2])))
|
|
(when base-rb
|
|
(send base-rb set-selection
|
|
(case (preferences:get 'drracket:create-executable-gui-base)
|
|
[(racket) 0]
|
|
[(gracket) 1])))
|
|
(reset-filename-suffix)
|
|
(send dlg show #t)
|
|
(cond
|
|
[cancelled? #f]
|
|
[else
|
|
(list
|
|
(if type-rb
|
|
(current-mode)
|
|
'no-show)
|
|
(if base-rb
|
|
(case (send base-rb get-selection)
|
|
[(0) 'mzscheme]
|
|
[(1) 'mred])
|
|
'no-show)
|
|
(send filename-text-field get-value))]))
|
|
|
|
(define (normalize-mode mode)
|
|
(case mode
|
|
[(launcher stand-alone distribution) mode]
|
|
;; Backward compatibility: interpret a boolean
|
|
[else (if mode 'launcher 'stand-alone)]))
|
|
|
|
;; put-executable : parent string (union boolean 'launcher 'stand-alone 'distribution) boolean -> (union false? string)
|
|
;; invokes the put-file dialog with arguments specific to building executables
|
|
(define (put-executable parent program-filename mode mred? title)
|
|
(let-values ([(base name dir) (split-path program-filename)])
|
|
(let ([mode (normalize-mode mode)])
|
|
(let ([default-name (default-executable-filename name mode mred?)])
|
|
(put-executable/defaults
|
|
parent
|
|
base
|
|
default-name
|
|
mode
|
|
mred?
|
|
title)))))
|
|
|
|
;; put-executable/defaults : parent string string symbol boolean -> (union false? string)
|
|
(define (put-executable/defaults parent default-dir default-name mode mred? title)
|
|
(let-values ([(extension style filters)
|
|
(mode->put-file-extension+style+filters mode mred?)])
|
|
(let* ([dir? (case mode
|
|
[(launcher)
|
|
(if mred?
|
|
(mred-launcher-is-directory?)
|
|
(mzscheme-launcher-is-directory?))]
|
|
[(stand-alone)
|
|
(embedding-executable-is-directory? mred?)]
|
|
[(distribution) #f])]
|
|
[users-name
|
|
(if dir?
|
|
(get-directory title
|
|
parent
|
|
default-dir
|
|
style)
|
|
(put-file title
|
|
parent
|
|
default-dir
|
|
default-name
|
|
extension
|
|
style
|
|
filters))])
|
|
(and users-name
|
|
(users-name-ok? mode extension parent users-name)
|
|
(or (not dir?)
|
|
(gui-utils:get-choice
|
|
(format (string-constant warning-directory-will-be-replaced)
|
|
users-name)
|
|
(string-constant yes)
|
|
(string-constant no)
|
|
(string-constant drscheme)
|
|
#f
|
|
parent))
|
|
users-name))))
|
|
|
|
;; users-name-ok? : symbol string (union #f frame% dialog%) path? -> boolean
|
|
;; returns #t if the string is an acceptable name for
|
|
;; a saved executable, and #f otherwise.
|
|
(define (users-name-ok? mode extension parent name)
|
|
(or (not extension)
|
|
(let ([suffix-m (regexp-match #rx"[.][^.]*$" (path->string name))])
|
|
(or (and suffix-m
|
|
(string=? (substring (car suffix-m) 1) extension))
|
|
(and
|
|
(message-box (string-constant drscheme)
|
|
(format
|
|
(string-constant ~a-must-end-with-~a)
|
|
(case mode
|
|
[(launcher) (string-constant launcher)]
|
|
[(stand-alone) (string-constant stand-alone)]
|
|
[(distribution) (string-constant distribution)])
|
|
name
|
|
extension)
|
|
parent)
|
|
#f)))))
|
|
|
|
;; default-executable-filename : path symbol boolean -> path
|
|
(define (default-executable-filename program-filename mode mred?)
|
|
(let ([ext (let-values ([(extension style filters)
|
|
(mode->put-file-extension+style+filters mode mred?)])
|
|
(if extension
|
|
(string->bytes/utf-8 (string-append "." extension))
|
|
#""))])
|
|
(path-replace-suffix program-filename ext)))
|
|
|
|
(define (mode->put-file-extension+style+filters mode mred?)
|
|
(case mode
|
|
[(launcher)
|
|
(if mred?
|
|
(mred-launcher-put-file-extension+style+filters)
|
|
(mzscheme-launcher-put-file-extension+style+filters))]
|
|
[(stand-alone)
|
|
(embedding-executable-put-file-extension+style+filters mred?)]
|
|
[(distribution)
|
|
(bundle-put-file-extension+style+filters)]))
|
|
|
|
;; create-module-based-stand-alone-executable : ... -> void (see docs)
|
|
(define (create-module-based-stand-alone-executable program-filename
|
|
executable-filename
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
gui?
|
|
use-copy?)
|
|
|
|
(with-handlers ([(λ (x) #f) ;exn:fail?
|
|
(λ (x)
|
|
(message-box
|
|
(string-constant drscheme)
|
|
(format "~a" (exn-message x)))
|
|
(void))])
|
|
(define init-code-tmp-filename (make-temporary-file "drs-standalone-exectable-init~a"))
|
|
(define bootstrap-tmp-filename (make-temporary-file "drs-standalone-exectable-bootstrap~a"))
|
|
(let ([init-code-mod-name
|
|
(let-values ([(base name dir?)
|
|
(split-path init-code-tmp-filename)])
|
|
(string->symbol (path->string name)))])
|
|
|
|
(call-with-output-file bootstrap-tmp-filename
|
|
(λ (port)
|
|
(write `(let () ;; cannot use begin, since it gets flattened to top-level (and re-compiled!)
|
|
,@(if module-language-spec
|
|
(if use-copy?
|
|
(list
|
|
`(namespace-require/copy ',module-language-spec))
|
|
(list
|
|
`(namespace-require/constant ',module-language-spec)))
|
|
'())
|
|
,@(if transformer-module-language-spec
|
|
(list `(namespace-require `(for-syntax ,transformer-module-language-spec)))
|
|
(list))
|
|
((dynamic-require ',init-code-mod-name 'init-code)))
|
|
port))
|
|
#:exists 'truncate
|
|
#:mode 'text)
|
|
|
|
(let ([new-init-code
|
|
(list*
|
|
(car init-code)
|
|
init-code-mod-name
|
|
(cddr init-code))])
|
|
(call-with-output-file init-code-tmp-filename
|
|
(λ (port)
|
|
(write new-init-code port))
|
|
#:exists 'truncate #:mode 'text)))
|
|
|
|
(let* ([pre-to-be-embedded-module-specs0
|
|
(cond
|
|
[(and module-language-spec transformer-module-language-spec)
|
|
(if (equal? module-language-spec transformer-module-language-spec)
|
|
(list module-language-spec)
|
|
(list module-language-spec transformer-module-language-spec))]
|
|
[module-language-spec
|
|
(list module-language-spec)]
|
|
[transformer-module-language-spec
|
|
(list transformer-module-language-spec)]
|
|
[else '()])]
|
|
[pre-to-be-embedded-module-specs1
|
|
(if gui?
|
|
(cons '(lib "mred/mred.rkt")
|
|
pre-to-be-embedded-module-specs0)
|
|
pre-to-be-embedded-module-specs0)]
|
|
[pre-to-be-embedded-module-specs2
|
|
(cons `(file ,(path->string init-code-tmp-filename))
|
|
pre-to-be-embedded-module-specs1)]
|
|
[pre-to-be-embedded-module-specs3
|
|
(filter (λ (x) (not (eq? x 'mzscheme)))
|
|
pre-to-be-embedded-module-specs2)]
|
|
[to-be-embedded-module-specs
|
|
(map (λ (x) (list #f x))
|
|
pre-to-be-embedded-module-specs3)])
|
|
|
|
(create-embedding-executable
|
|
executable-filename
|
|
#:mred? gui?
|
|
#:verbose? #f ;; verbose?
|
|
#:modules to-be-embedded-module-specs
|
|
#:literal-files (list
|
|
bootstrap-tmp-filename
|
|
program-filename)
|
|
#:cmdline (if gui?
|
|
(list "-mvqZ")
|
|
(list "-mvq"))))
|
|
(delete-file init-code-tmp-filename)
|
|
(delete-file bootstrap-tmp-filename)
|
|
(void)))
|
|
|
|
;; create-module-based-distribution : ... -> void (see docs)
|
|
(define (create-module-based-distribution program-filename
|
|
distribution-filename
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
gui?
|
|
use-copy?)
|
|
(create-distribution-for-executable
|
|
distribution-filename
|
|
gui?
|
|
(lambda (exe-name)
|
|
(create-module-based-stand-alone-executable program-filename
|
|
exe-name
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
gui?
|
|
use-copy?))))
|
|
|
|
;; create-distribution-for-executable : ... -> void (see docs)
|
|
(define (create-distribution-for-executable distribution-filename
|
|
gui?
|
|
make-executable)
|
|
;; Delete old file, if it exists:
|
|
(when (file-exists? distribution-filename)
|
|
(delete-file distribution-filename))
|
|
;; Figure out base name, and create working temp directory:
|
|
(let* ([base-name (let-values ([(base name dir?) (split-path distribution-filename)])
|
|
(path-replace-suffix name #""))]
|
|
[temp-dir
|
|
(make-temporary-file "drscheme-tmp-~a" 'directory)]
|
|
[c (make-custodian)]
|
|
[dialog (new dialog%
|
|
[label (string-constant distribution-progress-window-title)]
|
|
[width 400])]
|
|
[status-message
|
|
(new message%
|
|
[label (string-constant creating-executable-progress-status)]
|
|
[parent dialog]
|
|
[stretchable-width #t])]
|
|
[pane (new vertical-pane%
|
|
[parent dialog])]
|
|
[abort-button
|
|
(new button%
|
|
[parent pane]
|
|
[label (string-constant abort)]
|
|
[callback (lambda (_1 _2)
|
|
(custodian-shutdown-all c))])]
|
|
|
|
[exn #f]
|
|
|
|
[worker-thread
|
|
(parameterize ([current-custodian c])
|
|
(thread
|
|
(λ ()
|
|
(with-handlers ([exn? (λ (e) (set! exn e))])
|
|
;; Build the exe:
|
|
(make-directory (build-path temp-dir "exe"))
|
|
(let ([exe-name (build-path temp-dir "exe" (default-executable-filename base-name 'stand-alone gui?))])
|
|
(make-executable exe-name)
|
|
(when (or (file-exists? exe-name)
|
|
(directory-exists? exe-name))
|
|
(let ([dist-dir (build-path temp-dir base-name)])
|
|
;; Assemble the bundle directory:
|
|
(queue-callback
|
|
(λ ()
|
|
(send status-message set-label (string-constant assembling-distribution-files-progress-status))))
|
|
(assemble-distribution dist-dir (list exe-name))
|
|
;; Pack it:
|
|
(queue-callback
|
|
(λ ()
|
|
(send status-message set-label (string-constant packing-distribution-progress-status))))
|
|
(bundle-directory distribution-filename dist-dir #t))))))))])
|
|
|
|
;; create a thread that will trigger hiding the dialog and the return from `show'
|
|
;; when things are done (no matter if there was a kill, or just normal terminiation)
|
|
(thread
|
|
(λ ()
|
|
(thread-wait worker-thread)
|
|
(queue-callback (λ () (send dialog show #f)))))
|
|
|
|
(send dialog show #t)
|
|
|
|
;; Clean up:
|
|
(custodian-shutdown-all c)
|
|
(delete-directory/files temp-dir)
|
|
|
|
(when exn
|
|
(raise exn))))
|
|
|
|
|
|
(define (condense-scheme-code-string s)
|
|
(let ([i (open-input-string s)]
|
|
[o (open-output-string)])
|
|
(let loop ()
|
|
(let ([c (read-char i)])
|
|
(unless (eof-object? c)
|
|
(let ([next (λ ()
|
|
(display c o)
|
|
(loop))])
|
|
(case c
|
|
[(#\space)
|
|
(if (char=? #\( (peek-char i))
|
|
(loop)
|
|
(next))]
|
|
[(#\))
|
|
(if (eq? #\space (peek-char i))
|
|
(begin
|
|
(display #\) o)
|
|
(read-char i)
|
|
(loop))
|
|
(next))]
|
|
[(#\\)
|
|
(begin
|
|
(display #\\ o)
|
|
(display (read-char i) o)
|
|
(loop))]
|
|
[(#\" #\|)
|
|
(display c o)
|
|
(let loop ()
|
|
(let ([v (read-char i)])
|
|
(cond
|
|
[(eq? v c) (next)]
|
|
[(eq? v #\\)
|
|
(display v o)
|
|
(display (read-char i) o)
|
|
(loop)]
|
|
[else (display v o)
|
|
(loop)])))]
|
|
[else (next)])))))
|
|
(get-output-string o)))
|
|
|
|
(define (create-module-based-launcher program-filename
|
|
executable-filename
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
gui?
|
|
use-copy?)
|
|
|
|
(with-handlers ([(λ (x) #f) ;exn:fail?
|
|
(λ (x)
|
|
(message-box
|
|
(string-constant drscheme)
|
|
(format "~a" (exn-message x)))
|
|
(void))])
|
|
|
|
((if gui? make-mred-launcher make-mzscheme-launcher)
|
|
(list
|
|
(path->string
|
|
(collection-file-path (if gui?
|
|
"launcher-mred-bootstrap.rkt"
|
|
"launcher-mz-bootstrap.rkt")
|
|
"drracket" "private"))
|
|
(condense-scheme-code-string (format "~s" init-code))
|
|
(path->string program-filename)
|
|
(format "~s" module-language-spec)
|
|
(format "~s" transformer-module-language-spec)
|
|
(format "~s" use-copy?))
|
|
(if (path? executable-filename)
|
|
(path->string executable-filename)
|
|
executable-filename))))
|
|
|
|
;; initialize-module-based-language : boolean (or #f module-spec) module-spec ((-> void) -> void)
|
|
(define (initialize-module-based-language use-copy?
|
|
module-spec
|
|
transformer-module-spec
|
|
run-in-user-thread)
|
|
(run-in-user-thread
|
|
(λ ()
|
|
(with-handlers ([(λ (x) #t)
|
|
(λ (x)
|
|
(display (if (exn? x)
|
|
(exn-message x)
|
|
(format "~s" x)))
|
|
(newline))])
|
|
(when module-spec
|
|
(if use-copy?
|
|
(namespace-require/copy module-spec)
|
|
(namespace-require/constant module-spec)))
|
|
(when transformer-module-spec
|
|
(namespace-require `(for-syntax ,transformer-module-spec)))))))
|
|
|
|
;; module-based-language-front-end : (port reader -> (-> (union sexp syntax eof)))
|
|
;; type reader = type-spec-of-read-syntax (see mz manual for details)
|
|
(define (module-based-language-front-end port reader)
|
|
(λ ()
|
|
(let ([s (reader (object-name port) port)])
|
|
(if (syntax? s)
|
|
(namespace-syntax-introduce
|
|
(datum->syntax
|
|
#f
|
|
(cons '#%top-interaction s)
|
|
s))
|
|
s))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; snip/value extensions
|
|
;;
|
|
|
|
(define to-snips null)
|
|
(define-struct to-snip (predicate? >value setup-thunk))
|
|
(define add-snip-value
|
|
(lambda (predicate constructor [setup-thunk void])
|
|
(set! to-snips (cons (make-to-snip predicate constructor setup-thunk) to-snips))))
|
|
|
|
(define (value->snip v)
|
|
(ormap (λ (to-snip) (and ((to-snip-predicate? to-snip) v)
|
|
((to-snip->value to-snip) v)))
|
|
to-snips))
|
|
(define (to-snip-value? v)
|
|
(ormap (λ (to-snip) ((to-snip-predicate? to-snip) v)) to-snips))
|
|
(define (setup-setup-values)
|
|
(for-each (λ (t) ((to-snip-setup-thunk t))) to-snips))
|
|
|
|
|
|
(define capabilities '())
|
|
(define (capability-registered? x) (and (assoc x capabilities) #t))
|
|
(define (register-capability name contract default)
|
|
(when (capability-registered? name)
|
|
(error 'register-capability "already registered capability ~s" name))
|
|
(set! capabilities (cons (list name default contract) capabilities)))
|
|
(define (get-capability-default name)
|
|
(let ([l (assoc name capabilities)])
|
|
(unless l
|
|
(error 'get-capability-default "name not bound ~s" name))
|
|
(cadr l)))
|
|
(define (get-capability-contract name)
|
|
(let ([l (assoc name capabilities)])
|
|
(unless l
|
|
(error 'get-capability-contract "name not bound ~s" name))
|
|
(caddr l)))
|
|
|
|
|
|
;
|
|
;
|
|
; ;;;;;; ;
|
|
; ; ; ;
|
|
; ; ; ;; ;; ;;;;; ;;; ;; ;; ;;;; ;;; ;;; ;; ;; ;;;;
|
|
; ;;; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ;
|
|
; ; ; ;; ; ;;;;; ; ; ;;; ; ; ; ; ; ;;;
|
|
; ; ;; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;;;;; ;; ;; ;;; ;;;; ;;; ;;; ;;;; ;;;;; ;;; ;;; ;;; ;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
|
|
(define language-extensions null)
|
|
(define (get-language-extensions)
|
|
(drracket:tools:only-in-phase
|
|
'drracket:language:get-default-mixin
|
|
'phase2)
|
|
language-extensions)
|
|
|
|
(define (default-mixin x) x)
|
|
(define (get-default-mixin)
|
|
(drracket:tools:only-in-phase
|
|
'drracket:language:get-default-mixin
|
|
'phase2)
|
|
default-mixin)
|
|
|
|
(define (extend-language-interface extension<%> default-impl)
|
|
(drracket:tools:only-in-phase
|
|
'drracket:language:extend-language-interface
|
|
'phase1)
|
|
(set! default-mixin (compose default-impl default-mixin))
|
|
(set! language-extensions (cons extension<%> language-extensions)))
|