#lang racket/base (require mred racket/unit racket/port racket/class syntax/toplevel framework "eval-helpers.rkt" "drsig.rkt") ;; to ensure this guy is loaded (and the snipclass installed) ;; in the drracket namespace & eventspace ;; these things are for effect only! (require mrlib/cache-image-snip (prefix-in image-core: mrlib/image-core)) (define op (current-output-port)) (define (oprintf . args) (apply fprintf op args)) (provide eval@) (define-unit eval@ (import [prefix drracket:language-configuration: drracket:language-configuration/internal^] [prefix drracket:rep: drracket:rep^] [prefix drracket:init: drracket:init^] [prefix drracket:language: drracket:language^] [prefix drracket:unit: drracket:unit^]) (export drracket:eval^) (define (traverse-program/multiple language-settings init kill-termination #:gui-modules? [gui-modules? #t]) (let-values ([(eventspace custodian) (build-user-eventspace/custodian language-settings init kill-termination #:gui-modules? gui-modules?)]) (let ([language (drracket:language-configuration:language-settings-language language-settings)] [settings (drracket:language-configuration:language-settings-settings language-settings)]) (λ (input iter complete-program?) (define port (cond [(input-port? input) input] [else (let* ([text (drracket:language:text/pos-text input)] [start (drracket:language:text/pos-start input)] [end (drracket:language:text/pos-end input)] [text-port (open-input-text-editor text start end values (send text get-port-name))]) (port-count-lines! text-port) (let* ([line (send text position-paragraph start)] [column (- start (send text paragraph-start-position line))] [relocated-port (relocate-input-port text-port (+ line 1) column (+ start 1))]) (port-count-lines! relocated-port) relocated-port))])) (parameterize ([current-eventspace eventspace]) (queue-callback (λ () (let ([read-thnk (if complete-program? (send language front-end/complete-program port settings) (send language front-end/interaction port settings))]) (let loop () (let ([in (read-thnk)]) (cond [(eof-object? in) (iter in (λ () (void)))] [else (iter in (λ () (loop)))]))))))))))) (define (expand-program/multiple language-settings eval-compile-time-part? init kill-termination #:gui-modules? [gui-modules? #t]) (let ([res (traverse-program/multiple language-settings init kill-termination #:gui-modules? gui-modules?)]) (λ (input iter complete-program?) (let ([expanding-iter (λ (rd cont) (cond [(eof-object? rd) (iter rd cont)] [eval-compile-time-part? (iter (expand-top-level-with-compile-time-evals rd) cont)] [else (iter (expand rd) cont)]))]) (res input expanding-iter complete-program?))))) (define (expand-program input language-settings eval-compile-time-part? init kill-termination iter #:gui-modules? [gui-modules? #t]) ((expand-program/multiple language-settings eval-compile-time-part? init kill-termination #:gui-modules? gui-modules?) input iter #t)) (define (build-user-eventspace/custodian language-settings init kill-termination #:gui-modules? [gui-modules? #t]) (let* ([user-custodian (make-custodian)] [eventspace (parameterize ([current-custodian user-custodian]) (make-eventspace))] [language (drracket:language-configuration:language-settings-language language-settings)] [settings (drracket:language-configuration:language-settings-settings language-settings)] [eventspace-main-thread #f] [run-in-eventspace (λ (thnk) (parameterize ([current-eventspace eventspace]) (let ([sema (make-semaphore 0)] [ans #f]) (queue-callback (λ () (let/ec k (parameterize ([error-escape-handler (let ([drscheme-expand-program-error-escape-handler (λ () (k (void)))]) drscheme-expand-program-error-escape-handler)]) (set! ans (thnk)))) (semaphore-post sema))) (semaphore-wait sema) ans)))] [drs-snip-classes (get-snip-classes)]) (run-in-eventspace (λ () (current-custodian user-custodian) (set-basic-parameters drs-snip-classes #:gui-modules? gui-modules?) (drracket:rep:current-language-settings language-settings))) (send language on-execute settings run-in-eventspace) (run-in-eventspace (λ () (set! eventspace-main-thread (current-thread)) (init) (break-enabled #t))) (thread (λ () (thread-wait eventspace-main-thread) (kill-termination))) (values eventspace user-custodian))) ;; get-snip-classes : -> (listof snipclass) ;; returns a list of the snip classes in the current eventspace (define (get-snip-classes) (let loop ([n (send (get-the-snip-class-list) number)]) (if (zero? n) null (cons (send (get-the-snip-class-list) nth (- n 1)) (loop (- n 1)))))) ;; set-basic-parameters : (listof (is-a/c? snipclass%)) -> void ;; sets the parameters that are shared between the repl's initialization ;; and expand-program (define (set-basic-parameters snip-classes #:gui-modules? [gui-modules? #t]) (for-each (λ (snip-class) (send (get-the-snip-class-list) add snip-class)) snip-classes) (set-basic-parameters/no-gui) (for-each (λ (x) (namespace-attach-module drracket:init:system-namespace x)) to-be-copied-module-names) (when gui-modules? (for-each (λ (x) (namespace-attach-module drracket:init:system-namespace x)) to-be-copied-gui-module-names))) (define to-be-copied-gui-module-specs (list '(lib "mred/mred.rkt") '(lib "mrlib/cache-image-snip.rkt") '(lib "mrlib/image-core.rkt") '(lib "mrlib/matrix-snip.rkt"))) ;; these module specs are copied over to each new user's namespace (define to-be-copied-module-specs (list ''#%foreign '(lib "mzlib/pconvert-prop.rkt") '(lib "planet/terse-info.rkt"))) ;; ensure that they are all here. (for-each (λ (x) (dynamic-require x #f)) to-be-copied-module-specs) (for-each (λ (x) (dynamic-require x #f)) to-be-copied-gui-module-specs) ;; get the names of those modules. (define-values (to-be-copied-module-names to-be-copied-gui-module-names) (let ([get-name (λ (spec) (if (symbol? spec) spec ((current-module-name-resolver) spec #f #f)))]) (values (map get-name to-be-copied-module-specs) (map get-name to-be-copied-gui-module-specs)))) ;; build-input-port : string[file-exists?] -> (values input any) ;; constructs an input port for the load handler. Also ;; returns a value representing the source of code read from the file. (define (build-input-port filename) (let* ([p (open-input-file filename)] [chars (list (read-char p) (read-char p) (read-char p) (read-char p))]) (close-input-port p) (cond [(equal? chars (string->list "WXME")) (let ([text (make-object text%)]) (send text load-file filename) (let ([port (open-input-text-editor text)]) (port-count-lines! port) (values port text)))] [else (let ([port (open-input-file filename)]) (port-count-lines! port) (values port filename))]))))