diff --git a/collects/hierlist/hierlist.ss b/collects/hierlist/hierlist.ss deleted file mode 100644 index 5af40bfd..00000000 --- a/collects/hierlist/hierlist.ss +++ /dev/null @@ -1,56 +0,0 @@ - -(require-library "hierlists.ss" "hierlist") - -(invoke-open-unit/sig (require-library "hierlistr.ss" "hierlist") mred (mred : mred^)) - -#| - -;; Testing -(define f (make-object mred:frame% null "test")) -(define p (make-object mred:horizontal-panel% f)) -(define c (make-object (class-asi mred:hierarchical-list% - (public - [item-opened - (lambda (i) - (let ([f (send i user-data)]) - (when f (f i))))] - [select - (lambda (i) - (printf "Selected: ~a~n" - (if i - (send (send i get-buffer) get-flattened-text) - i)))] - [double-select - (lambda (s) - (printf "Double-click: ~a~n" - (send (send s get-buffer) get-flattened-text)))])) - p)) - -(define a (send c new-list)) -(send (send a get-buffer) insert "First Item: List") -(send (send (send a new-item) get-buffer) insert "Sub1") -(send (send (send a new-item) get-buffer) insert "Sub2") -(define a.1 (send a new-list)) -(send (send a.1 get-buffer) insert "Deeper List") -(send (send (send a.1 new-item) get-buffer) insert "Way Down") - -(define b (send c new-item)) -(send (send b get-buffer) insert "Second Item") - -(define d (send c new-list)) -(send (send d get-buffer) insert "dynamic") -(send d user-data (lambda (d) - (time (let loop ([i 30]) - (unless (zero? i) - (send (send (send d new-item) get-buffer) insert (number->string i)) - (loop (sub1 i))))))) - -(define x (send c new-list)) -(send (send x get-buffer) insert "x") - -(define y (send c new-item)) -(send (send y get-buffer) insert "y") - -(send f show #t) - -|# diff --git a/collects/mred/edit.ss b/collects/mred/edit.ss deleted file mode 100644 index c2deaa25..00000000 --- a/collects/mred/edit.ss +++ /dev/null @@ -1,969 +0,0 @@ -(unit/sig mred:edit^ - (import mred:wx^ - [mred:constants : mred:constants^] - [mred:connections : mred:connections^] - [mred:autosave : mred:autosave^] - [mred:finder : mred:finder^] - [mred:path-utils : mred:path-utils^] - [mred:mode : mred:mode^] - [mred:frame : mred:frame^] - [mred:scheme-paren : mred:scheme-paren^] - [mred:keymap : mred:keymap^] - [mred:icon : mred:icon^] - [mred:preferences : mred:preferences^] - [mred:gui-utils : mred:gui-utils^] - [mzlib:function : mzlib:function^]) - - (mred:debug:printf 'invoke "mred:edit@") - - (define-struct range (start end b/w-bitmap color caret-space?)) - (define-struct rectangle (left top right bottom b/w-bitmap color)) - - (mred:preferences:set-preference-default 'mred:verify-change-format #f - (lambda (x) - (or (not x) - (eq? x #t)))) - - (mred:preferences:set-preference-default 'mred:auto-set-wrap? #f - (lambda (x) - (or (not x) - (eq? x #t)))) - - (define make-snip% - (let ([sl (make-object wx:style-list%)]) - (send sl new-named-style "Standard" (send sl find-named-style "Basic")) - (let ([std (send sl find-named-style "Standard")]) - (lambda (snip%) - (class snip% args - (inherit set-style) - (public [edit% media-edit%]) - (sequence - (cond - [(null? args) - (super-init (make-object edit%))] - [(null? (car args)) - (apply super-init (make-object edit%) (cdr args))] - [else (apply super-init args)]) - (set-style std))))))) - - (define media-snip% (make-snip% wx:media-snip%)) - (define snip% (make-snip% wx:snip%)) - - (define make-std-buffer% - (lambda (buffer%) - (class buffer% args - (sequence (mred:debug:printf 'creation "creating a buffer")) - (inherit modified? get-filename save-file canvases - get-max-width get-admin) - (rename [super-set-modified set-modified] - [super-on-save-file on-save-file] - [super-on-focus on-focus] - [super-lock lock]) - - (public [editing-this-file? #f]) - - (public - [locked? #f] - [lock - (lambda (x) - (set! locked? x) - (super-lock x))] - [do-close (lambda () (void))] - - [get-edit-snip - (lambda () (make-object media-snip% - (make-object edit%)))] - [get-pasteboard-snip - (lambda () (make-object media-snip% - (make-object pasteboard%)))] - [on-new-box - (lambda (type) - (cond - [(= type wx:const-edit-buffer) - (get-edit-snip)] - [else (get-pasteboard-snip)]))]) - - (public - [get-file (lambda (d) - (let ([v (mred:finder:get-file d)]) - (if v - v - null)))] - [put-file (lambda (d f) (let ([v (mred:finder:put-file f d)]) - (if v - v - null)))] - [mode #f] - [set-mode-direct (lambda (v) (set! mode v))] - [set-mode - (lambda (m) - #f)]) - (sequence - (apply super-init args))))) - - (define make-pasteboard% make-std-buffer%) - - (define make-media-edit% - (lambda (super%) - (class super% args - (inherit canvases get-max-width get-admin split-snip get-snip-position - delete find-snip set-filename invalidate-bitmap-cache - begin-edit-sequence end-edit-sequence - set-autowrap-bitmap get-keymap mode set-mode-direct - set-file-format get-file-format get-frame - get-style-list modified? change-style set-modified - position-location get-extent) - - (rename [super-on-focus on-focus] - [super-on-local-event on-local-event] - - [super-on-set-focus on-set-focus] - [super-on-kill-focus on-kill-focus] - - [super-after-set-position after-set-position] - - [super-on-edit-sequence on-edit-sequence] - [super-on-change-style on-change-style] - [super-on-insert on-insert] - [super-on-delete on-delete] - [super-on-set-size-constraint on-set-size-constraint] - - [super-after-edit-sequence after-edit-sequence] - [super-after-change-style after-change-style] - [super-after-insert after-insert] - [super-after-delete after-delete] - [super-after-set-size-constraint after-set-size-constraint] - - [super-set-max-width set-max-width] - [super-load-file load-file] - [super-on-paint on-paint]) - - (private [styles-fixed-edit-modified? #f]) - - (private - [b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [b4 (box 0)] - [range-rectangles null] - [recompute-range-rectangles - (lambda () - (let ([new-rectangles - (lambda (range) - (let* ([start (range-start range)] - [end (range-end range)] - [b/w-bitmap (range-b/w-bitmap range)] - [color (range-color range)] - [caret-space? (range-caret-space? range)] - [start-eol? #f] - [end-eol? (if (= start end) - start-eol? - #t)]) - (let-values ([(start-x top-start-y) - (begin (position-location start b1 b2 #t start-eol? #t) - (values (if caret-space? - (+ 1 (unbox b1)) - (unbox b1)) - (unbox b2)))] - [(end-x top-end-y) - (begin (position-location end b1 b2 #t end-eol? #t) - (values (unbox b1) (unbox b2)))] - [(bottom-start-y) - (begin (position-location start b1 b2 #f start-eol? #t) - (unbox b2))] - [(bottom-end-y) - (begin (position-location end b1 b2 #f end-eol? #t) - (unbox b2))]) - (cond - [(= top-start-y top-end-y) - (list - (make-rectangle start-x - top-start-y - (if (= end-x start-x) - (+ end-x 1) - end-x) - bottom-start-y - b/w-bitmap - color))] - [else - (list - (make-rectangle start-x - top-start-y - 'right-edge - bottom-start-y - b/w-bitmap - color) - (make-rectangle 'left-edge - bottom-start-y - 'max-width - top-end-y - b/w-bitmap - color) - (make-rectangle 'left-edge - top-end-y - end-x - bottom-end-y - b/w-bitmap - color))]))))] - - [invalidate-rectangles - (lambda (rectangles) - (let-values ([(min-left max-right) - (let loop ([left #f] - [right #f] - [canvases canvases]) - (cond - [(null? canvases) - (values left right)] - [else - (let-values ([(this-left this-right) - (send (car canvases) - call-as-primary-owner - (lambda () - (send (get-admin) get-view b1 b2 b3 b4) - (let* ([this-left (unbox b1)] - [this-width (unbox b3)] - [this-right (+ this-left this-width)]) - (values this-left - this-right))))]) - (if left - (loop (min this-left left) - (max this-right right) - (cdr canvases)) - (loop this-left - this-right - (cdr canvases))))]))]) - (let loop ([left #f] - [top #f] - [right #f] - [bottom #f] - [rectangles rectangles]) - (cond - [(null? rectangles) - (when left - (invalidate-bitmap-cache left top (- right left) (- bottom top)))] - [else (let* ([r (car rectangles)] - - [rleft (rectangle-left r)] - [rright (rectangle-right r)] - [rtop (rectangle-top r)] - [rbottom (rectangle-bottom r)] - - [this-left (if (number? rleft) - rleft - min-left)] - [this-right (if (number? rright) - rright - max-right)] - [this-bottom rbottom] - [this-top rtop]) - (if left - (loop (min this-left left) - (min this-top top) - (max this-right right) - (max this-bottom bottom) - (cdr rectangles)) - (loop this-left - this-top - this-right - this-bottom - (cdr rectangles))))]))))] - [old-rectangles range-rectangles]) - - (set! range-rectangles - (mzlib:function:foldl (lambda (x l) (append (new-rectangles x) l)) - null ranges)) - (invalidate-rectangles (append old-rectangles - range-rectangles))))] - [ranges null] - [pen (make-object wx:pen% - "BLACK" - 0 - wx:const-stipple)] - [brush (make-object wx:brush% - "black" - wx:const-stipple)]) - (public - ;; the bitmap is used in b/w and the color is used in color. - [highlight-range - (opt-lambda (start end color bitmap [caret-space? #f]) - (mred:debug:printf 'highlight-range "highlight-range: adding range: ~a ~a" start end) - (let ([l (make-range start end bitmap color caret-space?)]) - (set! ranges (cons l ranges)) - (recompute-range-rectangles) - (lambda () - (mred:debug:printf 'highlight-range "highlight-range: removing range: ~a ~a" start end) - (set! ranges - (let loop ([r ranges]) - (cond - [(null? r) r] - [else (if (eq? (car r) l) - (cdr r) - (cons (car r) (loop (cdr r))))]))) - (recompute-range-rectangles))))] - - [on-paint - (lambda (before dc left top right bottom dx dy draw-caret) - (super-on-paint before dc left top right bottom dx dy draw-caret) - (for-each - (lambda (rectangle) - (let-values ([(view-x view-y view-width view-height) - (begin - (send (get-admin) get-view b1 b2 b3 b4) - (values (unbox b1) - (unbox b2) - (unbox b3) - (unbox b4)))]) - (let* ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)] - [old-logical-function (send dc get-logical-function)] - [b/w-bitmap (rectangle-b/w-bitmap rectangle)] - [color (let* ([rc (rectangle-color rectangle)] - [tmpc (make-object wx:colour% 0 0 0)]) - (if rc - (begin (send dc try-colour rc tmpc) - (and (<= (max (abs (- (send rc red) (send tmpc red))) - (abs (- (send rc blue) (send tmpc blue))) - (abs (- (send rc green) (send tmpc green)))) - 15) - rc)) - rc))] - [first-number (lambda (x y) (if (number? x) x y))] - [left (first-number (rectangle-left rectangle) view-x)] - [top (rectangle-top rectangle)] - [right (if (number? (rectangle-right rectangle)) - (rectangle-right rectangle) - (+ view-x view-width))] - [bottom (rectangle-bottom rectangle)] - [width (max 0 (- right left))] - [height (max 0 (- bottom top))]) - (let/ec k - (cond - [(and (not before) - color - (not (eq? wx:platform 'unix)) - (<= 8 (wx:display-depth))) - (send pen set-style wx:const-solid) - (send brush set-style wx:const-solid) - (send pen set-colour color) - (send brush set-colour color) - (send dc set-logical-function wx:const-and)] - [(and before - color - (<= 8 (wx:display-depth))) - (send* pen (set-style wx:const-solid) - (set-colour color)) - (send* brush (set-style wx:const-solid) - (set-colour color)) - (send dc set-logical-function wx:const-copy)] - [(and (not before) - (< (wx:display-depth) 8) - b/w-bitmap - (eq? wx:platform 'unix)) - (send pen set-stipple b/w-bitmap) - (send brush set-stipple b/w-bitmap)] - [else (k (void))]) - (send dc set-pen pen) - (send dc set-brush brush) - (send dc draw-rectangle - (+ left dx) - (+ top dy) - width - height) - (send dc set-logical-function old-logical-function) - (send dc set-pen old-pen) - (send dc set-brush old-brush))))) - range-rectangles))]) - - (public - [on-kill-focus - (lambda () - (super-on-kill-focus) - (let ([frame (get-frame)]) - (when (and frame - (is-a? frame mred:frame:empty-frame%)) - (send (get-keymap) - remove-chained-keymap - (ivar frame keymap)))))] - [on-set-focus - (lambda () - (super-on-set-focus) - (let ([frame (get-frame)]) - (when (and frame - (is-a? frame mred:frame:empty-frame%)) - (send (get-keymap) - chain-to-keymap - (ivar frame keymap) - #t))))]) - - (public - [set-mode - (lambda (m) - (if mode - (send mode deinstall this)) - (if (is-a? m mred:mode:mode%) - (begin - (set-mode-direct m) - (set-file-format (ivar m file-format)) - (send m install this) - (let ([new-delta (ivar m standard-style-delta)]) - (when new-delta - (send (send (get-style-list) - find-named-style "Standard") - set-delta new-delta)))) - (begin - (set-mode-direct #f) - (send (send (get-style-list) - find-named-style "Standard") - set-delta (make-object wx:style-delta%)))))] - [styles-fixed? #f] - [set-styles-fixed (lambda (b) (set! styles-fixed? b))]) - - (public - [on-focus - (lambda (on?) - (super-on-focus on?) - (when mode - (send mode on-focus this on?)))] - [on-local-event - (lambda (mouse) - (if (or (not mode) - (not (send mode on-event this mouse))) - (super-on-local-event mouse)))] - [on-insert - (lambda (start len) - (if (or (not mode) (send mode on-insert this start len)) - (super-on-insert start len)))] - [on-delete - (lambda (start len) - (if (or (not mode) (send mode on-delete this start len)) - (super-on-delete start len)))] - [on-change-style - (lambda (start len) - (when styles-fixed? - (set! styles-fixed-edit-modified? (modified?))) - (and (or (not mode) - (send mode on-change-style this start len)) - (super-on-change-style start len)))] - [on-edit-sequence - (lambda () - (when mode - (send mode on-edit-sequence this)) - (super-on-edit-sequence))] - [on-set-size-constraint - (lambda () - (and (or (not mode) (send mode on-set-size-constraint this)) - (super-on-set-size-constraint)))] - - [after-insert - (lambda (start len) - (when styles-fixed? - (change-style (send (get-style-list) find-named-style "Standard") - start - (+ start len))) - (when mode (send mode after-insert this start len)) - (super-after-insert start len))] - [after-delete - (lambda (start len) - (if mode (send mode after-delete this start len)) - (super-after-delete start len))] - [after-change-style - (lambda (start len) - (when mode (send mode after-change-style this start len)) - (super-after-change-style start len) - (when styles-fixed? - (set-modified styles-fixed-edit-modified?)))] - [after-edit-sequence - (lambda () - (when mode - (send mode after-edit-sequence this)) - (super-after-edit-sequence))] - [after-set-size-constraint - (lambda () - (when mode - (send mode after-set-size-constraint this)) - (super-after-set-size-constraint))] - [after-set-position - (lambda () - (when mode - (send mode after-set-position this)) - (super-after-set-position))]) - - (public - [set-max-width - (lambda (x) - (mred:debug:printf 'rewrap "rewrap: set-max-width: ~a" x) - (super-set-max-width x))] - [auto-set-wrap? (mred:preferences:get-preference 'mred:auto-set-wrap?)] - [set-auto-set-wrap - (lambda (v) - (mred:debug:printf 'rewrap - "rewrap: set-auto-set-wrap: ~a (canvases ~a)" - v canvases) - (set! auto-set-wrap? v) - (for-each (lambda (c) (send c resize-edit)) canvases))] - - [rewrap - (lambda () - (if auto-set-wrap? - (let* ([current-width (get-max-width)] - [w-box (box 0)] - [new-width - (mzlib:function:foldl - (lambda (canvas sofar) - (send canvas call-as-primary-owner - (lambda () - (send (get-admin) - get-view null null - w-box (box 0)))) - (max (unbox w-box) sofar)) - 0 - canvases)]) - (mred:debug:printf 'rewrap "rewrap: new-width ~a current-width ~a" - new-width current-width) - (when (and (not (= current-width new-width)) - (< 0 new-width)) - (set-max-width new-width) - (mred:debug:printf 'rewrap "rewrap: attempted to wrap to: ~a actually wrapped to ~a" - new-width (get-max-width)))) - (begin - (mred:debug:printf 'rewrap "rewrap: wrapping to -1") - (set-max-width -1))))]) - - (public - [move/copy-to-edit - (lambda (dest-edit start end dest-position) - (let ([insert-edit (ivar dest-edit insert)]) - (split-snip start) - (split-snip end) - (let loop ([snip (find-snip end wx:const-snip-before)]) - (cond - [(or (null? snip) (< (get-snip-position snip) start)) - (void)] - [else - (let ([prev (send snip previous)] - [released/copied (if (send snip release-from-owner) - snip - (let* ([copy (send snip copy)] - [snip-start (get-snip-position snip)] - [snip-end (+ snip-start (send snip get-count))]) - (delete snip-start snip-end) - snip))]) - '(wx:message-box (format "before: ~a" (eq? snip released/copied))) - (insert-edit released/copied dest-position dest-position) - '(wx:message-box (format "after: ~a" (eq? snip released/copied))) - (loop prev))]))))]) - - (public - [load-file - (opt-lambda ([filename null] [format wx:const-media-ff-guess]) - (let ([filename (if (null? filename) - (mred:finder:get-file) - filename)]) - (and filename - (if (file-exists? filename) - (super-load-file filename format) - (set-filename filename)))))]) - (public - [autowrap-bitmap null]) - (sequence - (apply super-init args) - (set-autowrap-bitmap autowrap-bitmap) - (let ([keymap (get-keymap)]) - (mred:keymap:set-keymap-error-handler keymap) - (mred:keymap:set-keymap-implied-shifts keymap) - (send keymap chain-to-keymap mred:keymap:global-keymap #f)))))) - - (define make-searching-edit% - (lambda (super%) - (class super% args - (inherit get-end-position get-start-position last-position - find-string get-snip-position get-admin find-snip - get-keymap) - (public - [find-string-embedded - (opt-lambda (str [direction 1] [start -1] - [end -1] [get-start #t] - [case-sensitive? #t] [pop-out? #f]) - (let/ec k - (let* ([start (if (= -1 start) - (if (= direction 1) - (get-end-position) - (get-start-position)) - start)] - [end (if (= -1 end) - (if (= direction 1) - (last-position) - 0) - end)] - [flat (find-string str direction - start end get-start - case-sensitive?)] - [end-test - (lambda (snip) - (cond - [(null? snip) flat] - [(and (not (= -1 flat)) - (let* ([start (get-snip-position snip)] - [end (+ start (send snip get-count))]) - (if (= direction 1) - (and (<= start flat) - (< flat end)) - (and (< start flat) - (<= flat end))))) - flat] - [else #f]))] - [pop-out - (lambda () - (let ([admin (get-admin)]) - (if (is-a? admin wx:media-snip-media-admin%) - (let* ([snip (send admin get-snip)] - [edit-above (send (send snip get-admin) get-media)] - [pos (send edit-above get-snip-position snip)]) - (send edit-above - find-string-embedded - str - direction - (if (= direction 1) (add1 pos) pos) - -1 get-start - case-sensitive? pop-out?)) - (values this -1))))]) - (let loop ([current-snip (find-snip start - (if (= direction 1) - wx:const-snip-after-or-null - wx:const-snip-before-or-null))]) - (let ([next-loop - (lambda () - (if (= direction 1) - (loop (send current-snip next)) - (loop (send current-snip previous))))]) - (cond - [(end-test current-snip) => - (lambda (x) - (if (and (= x -1) pop-out?) - (pop-out) - (values this x)))] - [(is-a? current-snip wx:media-snip%) - (let-values ([(embedded embedded-pos) - (let ([media (send current-snip get-this-media)]) - (and (not (null? media)) - (send media find-string-embedded str - direction - (if (= 1 direction) - 0 - (send media last-position)) - -1 - get-start case-sensitive?)))]) - (if (= -1 embedded-pos) - (next-loop) - (values embedded embedded-pos)))] - [else (next-loop)]))))))]) - (sequence - (apply super-init args) - (let ([keymap (get-keymap)]) - (mred:keymap:set-keymap-error-handler keymap) - (mred:keymap:set-keymap-implied-shifts keymap) - (send keymap chain-to-keymap mred:keymap:global-search-keymap #f)))))) - - (define make-file-buffer% - (lambda (super%) - (class super% args - (inherit get-keymap find-snip - get-filename lock get-style-list - modified? change-style set-modified - get-frame) - (rename [super-after-save-file after-save-file] - [super-after-load-file after-load-file]) - - (public [editing-this-file? #t]) - (private - [check-lock - (lambda () - (let* ([filename (get-filename)] - [lock? (and (not (null? filename)) - (file-exists? filename) - (not (member - 'write - (file-or-directory-permissions - filename))))]) - (mred:debug:printf 'permissions - "locking: ~a (filename: ~a)" - lock? - filename) - (lock lock?)))]) - (public - [after-save-file - (lambda (success) - (when success - (check-lock)) - (super-after-save-file success))] - - [after-load-file - (lambda (sucessful?) - (when sucessful? - (check-lock)) - (super-after-load-file sucessful?))] - [autowrap-bitmap (mred:icon:get-autowrap-bitmap)]) - (sequence - (apply super-init args) - (let ([keymap (get-keymap)]) - (mred:keymap:set-keymap-error-handler keymap) - (mred:keymap:set-keymap-implied-shifts keymap) - (send keymap chain-to-keymap mred:keymap:global-file-keymap #f)))))) - - (define make-clever-file-format-edit% - (lambda (super%) - (class-asi super% - (inherit get-file-format set-file-format find-snip) - (rename [super-on-save-file on-save-file] - [super-after-save-file after-save-file]) - - (private [restore-file-format void]) - - (public - [after-save-file - (lambda (success) - (restore-file-format) - (super-after-save-file success))] - [on-save-file - (let ([has-non-text-snips - (lambda () - (let loop ([s (find-snip 0 wx:const-snip-after)]) - (cond - [(null? s) #f] - [(is-a? s wx:text-snip%) - (loop (send s next))] - [else #t])))]) - (lambda (name format) - (when (and (or (= format wx:const-media-ff-same) - (= format wx:const-media-ff-copy)) - (not (= (get-file-format) - wx:const-media-ff-std))) - (cond - [(= format wx:const-media-ff-copy) - (set! restore-file-format - (let ([f (get-file-format)]) - (lambda () - (set! restore-file-format void) - (set-file-format f)))) - (set-file-format wx:const-media-ff-std)] - [(and (has-non-text-snips) - (or (not (mred:preferences:get-preference 'mred:verify-change-format)) - (mred:gui-utils:get-choice "Save this file as plain text?" "No" "Yes"))) - (set-file-format wx:const-media-ff-std)] - [else (void)])) - (or (super-on-save-file name format) - (begin - (restore-file-format) - #f))))])))) - - (define make-backup-autosave-buffer% - (lambda (super-edit%) - (class super-edit% args - (inherit modified? get-filename save-file) - (rename [super-on-save-file on-save-file] - [super-on-change on-change] - [super-do-close do-close] - [super-set-modified set-modified]) - (private - [auto-saved-name #f] - [auto-save-out-of-date? #t] - [auto-save-error? #f]) - (public - [backup? #t] - [on-save-file - (lambda (name format) - (set! auto-save-error? #f) - (and (super-on-save-file name format) - (begin - (when (and backup? - (not (= format wx:const-media-ff-copy)) - (file-exists? name)) - (let ([back-name (mred:path-utils:generate-backup-name name)]) - (copy-file name back-name))) - #t)))] - [do-close - (lambda () - (super-do-close) - (remove-autosave) - (set! auto-save? #f))] - [on-change - (lambda () - (super-on-change) - (set! auto-save-out-of-date? #t))] - [auto-save? #t] - [set-modified - (lambda (modified?) - (when auto-saved-name - (if (not modified?) - (begin - (delete-file auto-saved-name) - (set! auto-saved-name #f)) - (set! auto-save-out-of-date? #t))) - (super-set-modified modified?))] - [do-autosave - (lambda () - (when (and auto-save? - (not auto-save-error?) - (modified?) - (or (not auto-saved-name) - auto-save-out-of-date?)) - (let* ([orig-name (get-filename)] - [auto-name (mred:path-utils:generate-autosave-name orig-name)] - [success (save-file auto-name wx:const-media-ff-copy)]) - (if success - (begin - (when auto-saved-name - (delete-file auto-saved-name)) - (set! auto-saved-name auto-name) - (set! auto-save-out-of-date? #f)) - (begin - (wx:message-box - (format "Error autosaving ~s.~n~a~n~a" - (if (null? orig-name) "Untitled" orig-name) - "Autosaving is turned off" - "until the file is saved.") - "Warning") - (set! auto-save-error? #t))))))] - [remove-autosave - (lambda () - (when auto-saved-name - (delete-file auto-saved-name) - (set! auto-saved-name #f)))]) - (sequence - (apply super-init args) - (mred:autosave:register-autosave this))))) - - (define make-return-edit% - (lambda (super%) - (class super% (return . args) - (rename [super-on-local-char on-local-char]) - (public - [on-local-char - (lambda (key) - (let ([cr-code 13] - [lf-code 10] - [code (send key get-key-code)]) - (or (and (or (= lf-code code) - (= cr-code code)) - (return)) - (super-on-local-char key))))]) - (sequence - (apply super-init args))))) - - (define make-info-edit% - (lambda (super-info-edit%) - (class-asi super-info-edit% - (inherit get-frame get-start-position get-end-position - position-line line-start-position) - (rename [super-after-set-position after-set-position] - [super-after-edit-sequence after-edit-sequence] - [super-on-edit-sequence on-edit-sequence] - [super-after-insert after-insert] - [super-after-delete after-delete] - [super-lock lock] - [super-set-overwrite-mode set-overwrite-mode] - [super-set-anchor set-anchor]) - (private - [edit-sequence-depth 0] - [position-needs-updating #f] - [lock-needs-updating #f] - [anchor-needs-updating #f] - [overwrite-needs-updating #f] - [maybe-update-anchor - (lambda () - (if (= edit-sequence-depth 0) - (let ([frame (get-frame)]) - (when frame - (send frame anchor-status-changed))) - (set! anchor-needs-updating #t)))] - [maybe-update-overwrite - (lambda () - (if (= edit-sequence-depth 0) - (let ([frame (get-frame)]) - (when frame - (send frame overwrite-status-changed))) - (set! overwrite-needs-updating #t)))] - [maybe-update-lock-icon - (lambda () - (if (= edit-sequence-depth 0) - (let ([frame (get-frame)]) - (when frame - (send frame lock-status-changed))) - (set! lock-needs-updating #t)))] - [maybe-update-position-edit - (lambda () - (if (= edit-sequence-depth 0) - (update-position-edit) - (set! position-needs-updating #t)))] - [update-position-edit - (lambda () - (let ([frame (get-frame)]) - (when frame - (send frame edit-position-changed))))]) - - (public - [set-anchor - (lambda (x) - (super-set-anchor x) - (maybe-update-anchor))] - [set-overwrite-mode - (lambda (x) - (super-set-overwrite-mode x) - (maybe-update-overwrite))] - [lock - (lambda (x) - (super-lock x) - (maybe-update-lock-icon))] - [after-set-position - (lambda () - (maybe-update-position-edit) - (super-after-set-position))] - [after-insert - (lambda (start len) - (maybe-update-position-edit) - (super-after-insert start len))] - [after-delete - (lambda (start len) - (maybe-update-position-edit) - (super-after-delete start len))] - [after-edit-sequence - (lambda () - (super-after-edit-sequence) - (set! edit-sequence-depth (sub1 edit-sequence-depth)) - (when (= 0 edit-sequence-depth) - (let ([frame (get-frame)]) - (when anchor-needs-updating - (set! anchor-needs-updating #f) - (send frame overwrite-status-changed)) - (when position-needs-updating - (set! position-needs-updating #f) - (update-position-edit)) - (when lock-needs-updating - (set! lock-needs-updating #f) - (send frame lock-status-changed)))))] - [on-edit-sequence - (lambda () - (set! edit-sequence-depth (add1 edit-sequence-depth)) - (super-on-edit-sequence))])))) - - - (define media-edit% (make-media-edit% - (make-std-buffer% - mred:connections:connections-media-edit%))) - (define searching-edit% (make-searching-edit% media-edit%)) - - (define info-edit% (make-info-edit% searching-edit%)) - (define clever-file-format-edit% (make-clever-file-format-edit% info-edit%)) - (define file-edit% (make-file-buffer% clever-file-format-edit%)) - (define backup-autosave-edit% (make-backup-autosave-buffer% file-edit%)) - - (define edit% file-edit%) - - (define return-edit% (make-return-edit% media-edit%)) - - (define pasteboard% (make-pasteboard% - mred:connections:connections-media-pasteboard%)) - (define file-pasteboard% (make-file-buffer% pasteboard%)) - (define backup-autosave-pasteboard% (make-backup-autosave-buffer% - file-pasteboard%))) diff --git a/collects/mred/exit.ss b/collects/mred/exit.ss deleted file mode 100644 index 2aa07318..00000000 --- a/collects/mred/exit.ss +++ /dev/null @@ -1,58 +0,0 @@ - - (unit/sig mred:exit^ - (import mred:wx^ - [mred:constants : mred:constants^] - [mred:preferences : mred:preferences^] - [mred:gui-utils : mred:gui-utils^]) - (rename (-exit exit)) - - (mred:debug:printf 'invoke "mred:exit@") - - (define exit-callbacks '()) - - (define insert-exit-callback - (lambda (f) - (set! exit-callbacks (cons f exit-callbacks)) - f)) - - (define remove-exit-callback - (lambda (cb) - (set! exit-callbacks - (let loop ([cb-list exit-callbacks]) - (cond - [(null? cb-list) ()] - [(eq? cb (car cb-list)) (cdr cb-list)] - [else (cons (car cb-list) (loop (cdr cb-list)))]))))) - - (define run-exit-callbacks - (lambda () - (let*-values ([(w capW) - (if (eq? wx:platform 'windows) - (values "exit" "Exit") - (values "quit" "Quit"))] - [(message) - (string-append "Are you sure you want to " - w - "?")]) - (let/ec k - (when (mred:preferences:get-preference 'mred:verify-exit) - (unless (mred:gui-utils:get-choice - message capW "Cancel") - (k #f))) - (let loop ([cb-list exit-callbacks]) - (cond - [(null? cb-list) #t] - [(not ((car cb-list))) #f] - [else (loop (cdr cb-list))])))))) - - (define -exit - (let*-values ([(exiting?) #f]) - (opt-lambda ([just-ran-callbacks? #f]) - (unless exiting? - (dynamic-wind - (lambda () (set! exiting? #t)) - (lambda () - (if (or just-ran-callbacks? (run-exit-callbacks)) - (exit) - #f)) - (lambda () (set! exiting? #f)))))))) \ No newline at end of file diff --git a/collects/mred/finder.ss b/collects/mred/finder.ss deleted file mode 100644 index eed6c59e..00000000 --- a/collects/mred/finder.ss +++ /dev/null @@ -1,560 +0,0 @@ - - (unit/sig mred:finder^ - (import mred:wx^ - [mred:constants : mred:constants^] - [mred:container : mred:container^] - [mred:preferences : mred:preferences^] - [mred:gui-utils : mred:gui-utils^] - [mred:edit : mred:edit^] - [mred:canvas : mred:canvas^] - [mzlib:string : mzlib:string^] - [mzlib:function : mzlib:function^] - [mzlib:file : mzlib:file^]) - - (mred:debug:printf 'invoke "mred:finder@") - - (define filter-match? - (lambda (filter name msg) - (let-values ([(base name dir?) (split-path name)]) - (if (mzlib:string:regexp-match-exact? filter name) - #t - (begin - (wx:message-box msg "Error") - #f))))) - - (define last-directory #f) - - (define make-relative - (lambda (s) s)) - - (define current-find-file-directory - (opt-lambda ([dir 'get]) - (cond - [(eq? dir 'get) - (if (not last-directory) - (set! last-directory (current-directory))) - last-directory] - [(and (string? dir) - (directory-exists? dir)) - (set! last-directory dir) - #t] - [else #f]))) - - (mred:preferences:set-preference-default 'mred:show-periods-in-dirlist #f - (lambda (x) - (or (not x) - (eq? x #t)))) - - (define finder-dialog% - (class mred:container:dialog-box% (save-mode? replace-ok? multi-mode? - result-box start-dir - start-name prompt - file-filter file-filter-msg) - (inherit new-line tab fit center - show - popup-menu) - - (private - [WIDTH 500] - [HEIGHT 400] - - dirs current-dir - last-selected - [select-counter 0]) - - (private - [set-directory - (lambda (dir) ; dir is normalied - (mred:gui-utils:show-busy-cursor - (lambda () - (set! current-dir dir) - (set! last-directory dir) - (let-values - ([(dir-list menu-list) - (let loop ([this-dir dir] - [dir-list ()] - [menu-list ()]) - (let-values ([(base-dir in-dir dir?) (split-path this-dir)]) - (if (eq? wx:platform 'windows) - (mzlib:string:string-lowercase! in-dir)) - (let* ([dir-list (cons this-dir dir-list)] - [menu-list (cons in-dir menu-list)]) - (if base-dir - (loop base-dir dir-list menu-list) - ; No more - (values dir-list menu-list)))))]) - (set! dirs (reverse dir-list)) - (send* directory-edit - (begin-edit-sequence) - (erase) - (insert dir) - (end-edit-sequence)) - (send dir-choice clear) - (let loop ([choices (reverse menu-list)]) - (unless (null? choices) - (send dir-choice append (car choices)) - (loop (cdr choices)))) - (send dir-choice set-selection 0) - (send top-panel force-redraw)) - - (send name-list clear) - (send name-list set - (mzlib:function:quicksort - (let ([no-periods? (not (mred:preferences:get-preference - 'mred:show-periods-in-dirlist))]) - (let loop ([l (directory-list dir)]) - (if (null? l) - null - (let ([s (car l)] - [rest (loop (cdr l))]) - (cond - [(and no-periods? - (<= 1 (string-length s)) - (char=? (string-ref s 0) #\.)) - rest] - [(directory-exists? (build-path dir s)) - (cons (string-append s - (case wx:platform - [(unix) "/"] - [(windows) "\\"] - [else ":"])) - rest)] - [(or (not file-filter) - (mzlib:string:regexp-match-exact? file-filter s)) - (cons s rest)] - [else rest]))))) - (if (eq? wx:platform 'unix) string (send result-list find-string name) -1)) - (set! select-counter (add1 select-counter)) - (send result-list append (mzlib:file:normalize-path name))))] - [do-add - (lambda args - (let ([name (send name-list get-string-selection)]) - (if (string? name) - (let ([name (build-path current-dir - (make-relative name))]) - (add-one name)))))] - [do-add-all - (lambda args - (let loop ([n 0]) - (let ([name (send name-list get-string n)]) - (if (and (string? name) - (positive? (string-length name))) - (let ([name (build-path current-dir - (make-relative name))]) - (add-one name) - (loop (add1 n)))))))] - [do-remove - (lambda args - (let loop ([n 0]) - (if (< n select-counter) - (if (send result-list selected? n) - (begin - (send result-list delete n) - (set! select-counter (sub1 select-counter)) - (loop n)) - (loop (add1 n))))))] - - [do-cancel - (lambda args - (set-box! result-box #f) - (show #f))] - - [on-close (lambda () #f)]) - (sequence - (super-init () (if save-mode? "Put File" "Get File") - #t 300 300 WIDTH HEIGHT)) - - (private - [main-panel (make-object mred:container:vertical-panel% this)] - [top-panel (make-object mred:container:horizontal-panel% main-panel)] - [_1 (make-object mred:container:message% top-panel prompt)] - [dir-choice (make-object mred:container:choice% top-panel do-dir '())] - - [middle-panel (make-object mred:container:horizontal-panel% main-panel)] - [left-middle-panel (make-object mred:container:vertical-panel% middle-panel)] - [right-middle-panel (when multi-mode? (make-object mred:container:vertical-panel% middle-panel))] - [name-list% - (class-asi mred:container:list-box% - (public - [on-default-action - (lambda () - (let* ([which (send name-list get-string-selection)] - [dir (build-path current-dir - (make-relative which))]) - (if (directory-exists? dir) - (set-directory (mzlib:file:normalize-path dir)) - (if save-mode? - (send name-field set-value which) - (if multi-mode? - (do-add) - (do-ok))))))]))] - [name-list (make-object name-list% - left-middle-panel do-name-list - () wx:const-single - -1 -1 - (if multi-mode? (* 1/2 WIDTH) WIDTH) 300 - () wx:const-needed-sb)] - [save-panel (when save-mode? (make-object mred:container:horizontal-panel% main-panel))] - [directory-panel (make-object mred:container:horizontal-panel% main-panel)] - [directory-edit (make-object (class-asi mred:edit:media-edit% - (rename [super-on-local-char on-local-char]) - (public - [on-local-char - (lambda (key) - (let ([cr-code 13] - [lf-code 10] - [code (send key get-key-code)]) - (if (or (= code cr-code) - (= code lf-code)) - (do-go) - (super-on-local-char key))))])))] - - [period-panel (when (eq? 'unix wx:platform) - (make-object mred:container:horizontal-panel% main-panel))] - [bottom-panel (make-object mred:container:horizontal-panel% main-panel)] - [result-list - (when multi-mode? - (make-object mred:container:list-box% - right-middle-panel do-result-list - () - (if (eq? wx:window-system 'motif) - wx:const-extended - wx:const-multiple) - -1 -1 - (* 1/2 WIDTH) 300 - () wx:const-needed-sb))] - [add-panel (when multi-mode? (make-object mred:container:horizontal-panel% left-middle-panel))] - [remove-panel (when multi-mode? (make-object mred:container:horizontal-panel% right-middle-panel))] - [do-go - (lambda () - (let ([t (send directory-edit get-text)]) - (cond - [(file-exists? t) - (set-box! result-box (mzlib:file:normalize-path t)) - (show #f)] - [(directory-exists? t) - (set-directory (mzlib:file:normalize-path t))] - [else (wx:message-box (format "~a doesn't exist" t))])))]) - - (sequence - (when (eq? wx:platform 'unix) - (make-object mred:container:check-box% period-panel - do-period-in/exclusion - "Show files and directories that begin with a period") - (send period-panel stretchable-in-y #f)) - - (send directory-panel stretchable-in-y #f) - (let ([canvas (make-object mred:canvas:one-line-canvas% directory-panel -1 -1 -1 20 "" - (+ wx:const-mcanvas-hide-h-scroll - wx:const-mcanvas-hide-v-scroll))]) - (send* canvas - (set-media directory-edit) - (set-focus) - (user-min-height 20))) - (make-object mred:container:button% directory-panel - (lambda (button evt) (do-go)) - "Go") - - (when multi-mode? - (send add-panel stretchable-in-y #f) - (send remove-panel stretchable-in-y #f) - (send result-list stretchable-in-x #t)) - (send name-list stretchable-in-x #t) - (send top-panel stretchable-in-y #f) - (send bottom-panel stretchable-in-y #f) - (when save-mode? - (send save-panel stretchable-in-y #f))) - - (private - [name-field - (when save-mode? - (let* ([% (class-asi mred:container:text% - (public - [on-default-action - (lambda () - (do-ok))]))] - [v (make-object % - save-panel do-name - "Name: " "" - -1 -1 - 400 -1 - wx:const-process-enter)]) - (send v stretchable-in-x #t) - (if (string? start-name) - (send v set-value start-name)) - (new-line) - v))] - [into-dir-button - (when save-mode? - (make-object mred:container:button% - save-panel do-into-dir "Open Directory"))] - [add-button (when multi-mode? - (make-object mred:container:horizontal-panel% add-panel) - (make-object mred:container:button% - add-panel do-add - "Add"))] - [add-all-button (when multi-mode? - (begin0 - (make-object mred:container:button% - add-panel do-add-all - "Add All") - (make-object mred:container:horizontal-panel% add-panel)))] - [remove-button (when multi-mode? - (make-object mred:container:horizontal-panel% remove-panel) - (begin0 - (make-object mred:container:button% - remove-panel do-remove - "Remove") - (make-object mred:container:horizontal-panel% remove-panel)))]) - (sequence - (make-object mred:container:vertical-panel% bottom-panel)) - (private - [cancel-button (make-object mred:container:button% - bottom-panel do-cancel - "Cancel")] - [ok-button - (let ([w (send cancel-button get-width)]) - (make-object mred:container:button% - bottom-panel do-ok - "OK" -1 -1 w))]) - (sequence - (cond - [(and start-dir - (not (null? start-dir)) - (directory-exists? start-dir)) - (set-directory (mzlib:file:normalize-path start-dir))] - [last-directory (set-directory last-directory)] - [else (set-directory (current-directory))]) - - (send ok-button user-min-width (send cancel-button get-width)) - - (center wx:const-both) - - (show #t)))) - - (define make-common - (lambda (box-value make-dialog) - (let ([s (make-semaphore 1)] - [v (box box-value)] - [d #f]) - (lambda x - (semaphore-wait s) - (if d - (let ([my-d d] - [my-v v]) - (set! d #f) - (set! v #f) - (semaphore-post s) - (send my-d show #t) - (begin0 (unbox my-v) - (semaphore-wait s) - (set! d my-d) - (set! v my-v) - (semaphore-post s))) - (begin - (semaphore-post s) - (let* ([my-v (box box-value)] - [my-d (apply make-dialog my-v x)]) - (semaphore-wait s) - (unless d - (set! d my-d) - (set! v my-v)) - (begin0 (unbox my-v) - (semaphore-post s))))))))) - - (define common-put-file - (make-common - #f - (opt-lambda (box - [name ()][directory ()][replace? #f] - [prompt "Select File"][filter #f] - [filter-msg "That name does not have the right form"]) - (let* ([directory (if (and (null? directory) - (string? name)) - (or (mzlib:file:path-only name) null) - directory)] - [name (or (and (string? name) - (mzlib:file:file-name-from-path name)) - name)]) - (make-object finder-dialog% #t replace? #f box - directory name prompt filter filter-msg))))) - - (define common-get-file - (make-common - #f - (opt-lambda - (box [directory ()][prompt "Select File"][filter #f] - [filter-msg "Bad name"]) - (make-object finder-dialog% #f #f #f box directory '() prompt - filter filter-msg)))) - - (define common-get-file-list - (make-common - null - (opt-lambda (box [directory ()][prompt "Select Files"][filter #f] - [filter-msg "Bad name"]) - (make-object finder-dialog% #f #f #t box directory '() prompt - filter filter-msg)))) - - (define std-put-file - (opt-lambda ([name ()][directory ()][replace? #f][prompt "Select File"] - [filter #f] - [filter-msg - "That filename does not have the right form."]) - (let* ([directory (if (and (null? directory) - (string? name)) - (or (mzlib:file:path-only name) null) - directory)] - [name (or (and (string? name) - (mzlib:file:file-name-from-path name)) - name)] - [f (wx:file-selector prompt directory name - '() - (if (eq? wx:platform 'windows) - "*.*" - "*") - wx:const-save)]) - (if (or (null? f) - (and filter - (not (filter-match? filter - f - filter-msg)))) - #f - (let* ([f (mzlib:file:normalize-path f)] - [dir (mzlib:file:path-only f)] - [name (mzlib:file:file-name-from-path f)]) - (cond - [(not (and (string? dir) (directory-exists? dir))) - (wx:message-box "Error" "That directory does not exist.") - #f] - [(or (not name) (equal? name "")) - (wx:message-box "Error" "Empty filename.") - #f] - [else f])))))) - - (define std-get-file - (opt-lambda ([directory ()][prompt "Select File"][filter #f] - [filter-msg - "That filename does not have the right form."]) - (let ([f (wx:file-selector prompt directory)]) - (if (null? f) - #f - (if (or (not filter) (filter-match? filter f filter-msg)) - (let ([f (mzlib:file:normalize-path f)]) - (cond - [(directory-exists? f) - (wx:message-box "Error" - "That is a directory name.") - #f] - [(not (file-exists? f)) - (wx:message-box "That file does not exist.") - #f] - [else f])) - #f))))) - - (mred:preferences:set-preference-default 'mred:file-dialogs - (if (eq? wx:platform 'unix) - 'common - 'std) - (lambda (x) - (or (eq? x 'common) - (eq? x 'std)))) - - (define put-file - (lambda args - (apply (case (mred:preferences:get-preference 'mred:file-dialogs) - [(std) std-put-file] - [(common) common-put-file]) - args))) - (define get-file - (lambda args - (apply (case (mred:preferences:get-preference 'mred:file-dialogs) - [(std) std-get-file] - [(common) common-get-file]) - args)))) diff --git a/collects/mred/keys.ss b/collects/mred/keys.ss deleted file mode 100644 index a07b5b3e..00000000 --- a/collects/mred/keys.ss +++ /dev/null @@ -1,948 +0,0 @@ - - (unit/sig mred:keymap^ - (import mred:wx^ - [mred:constants : mred:constants^] - [mred:preferences : mred:preferences^] - [mred:exit : mred:exit^] - [mred:finder : mred:finder^] - [mred:handler : mred:handler^] - [mred:find-string : mred:find-string^] - [mred:scheme-paren : mred:scheme-paren^] - [mred:gui-utils : mred:gui-utils^]) - - (mred:debug:printf 'invoke "mred:keymap@") - - ; This is a list of keys that are typed with the SHIFT key, but - ; are not normally thought of as shifted. It will have to be - ; changed for different keyboards. - (define shifted-key-list - '("<" ">" "?" ":" "~" "\"" - "{" "}" - "!" "@" "#" "$" "%" "^" "&" "*" "(" ")" "_" "+" - "|")) - - (define keyerr - (lambda (str) - (display str (current-error-port)) - (newline (current-error-port)))) - - (define (set-keymap-error-handler keymap) - (send keymap set-error-callback keyerr)) - - (define (set-keymap-implied-shifts keymap) - (map (lambda (k) (send keymap implies-shift k)) - shifted-key-list)) - - (define (make-meta-prefix-list key) - (list (string-append "m:" key) - (string-append "c:[;" key) - (string-append "ESC;" key))) - - (define send-map-function-meta - (lambda (keymap key func) - (for-each (lambda (key) - (send keymap map-function key func)) - (make-meta-prefix-list key)))) - - (mred:preferences:set-preference-default 'mred:delete-forward? - (not (eq? wx:platform 'unix)) - (lambda (x) - (or (not x) - (eq? x #t)))) - - (define setup-global-search-keymap - (let* ([find-frame - (lambda (event) - (let loop ([p (send event get-event-object)]) - (if (is-a? p wx:frame%) - p - (loop (send p get-parent)))))] - [find-string-reverse - (lambda (edit event) - (send (find-frame event) search -1) - #t)] - [find-string - (lambda (edit event) - (send (find-frame event) search 1) - #t)] - [toggle-search-focus - (lambda (edit event) - (send (find-frame event) toggle-search-focus) - #t)]) - (lambda (kmap) - (let* ([map (lambda (key func) - (send kmap map-function key func))] - [map-meta (lambda (key func) - (send-map-function-meta kmap key func))] - [add (lambda (name func) - (send kmap add-key-function name func))] - [add-m (lambda (name func) - (send kmap add-mouse-function name func))]) - - - (add "initiate-search" toggle-search-focus) - (add "find-string" find-string) - (add "find-string-reverse" find-string-reverse) - - (map "c:i" "initiate-search") - (map "c:s" "find-string") - (map "c:r" "find-string-reverse") - (map-meta "%" "find-string"))))) - - (define setup-global-file-keymap - (let* ([rcs - (let ([last-checkin-string ""]) - (mred:preferences:set-preference-default - 'rcs-pathname (list "/usr/local/RCS/" "/usr/bin/" "/usr/local/bin/") - (lambda (x) - (and (list? x) - (andmap string? x)))) - (lambda (edit event) - (let/ec k - (let* ([rcs-binaries (list "ci" "co" "rlog")] - [rcs-pathname (let loop ([paths (mred:preferences:get-preference 'rcs-pathname)]) - (cond - [(null? paths) (k (wx:message-box "could not find RCS binaries."))] - [else (if (andmap (lambda (b) - (file-exists? (build-path (car paths) b))) - rcs-binaries) - (car paths) - (loop (cdr paths)))]))] - [filename (send edit get-filename)] - [username (wx:get-user-id)]) - (when (null? filename) - (k (wx:message-box "no file associated with this edit"))) - (let-values ([(my-out my-in my-pid my-err) - (apply values (process* (build-path rcs-pathname "rlog") - "-L" "-R" (string-append "-l" username) filename))]) - (let-values ([(their-out their-in their-pid their-err) - (apply values (process* (build-path rcs-pathname "rlog") - "-L" "-R" "-l" filename))]) - (let ([my-lock? (not (eof-object? (read my-out)))] - [locked? (not (eof-object? (read their-out)))]) - (for-each close-input-port (list my-out my-err their-out their-err)) - (for-each close-output-port (list my-in their-in)) - (cond - [(not (system* (build-path rcs-pathname "rlog") "-h" "-q" filename)) - (system* (build-path rcs-pathname "ci") "-t-" filename) - (wx:message-box "Initial Checkin Completed")] - [my-lock? - (when (send edit modified?) - (case (mred:gui-utils:unsaved-warning (send edit get-filename) "Checkin" #t) - [(save) (send edit save-file (send edit get-filename) - (send edit get-file-format))] - [(cancel) (k (void))] - [else (void)])) - (let* ([msg (mred:gui-utils:get-text-from-user - "Please Enter Log Message" - "Check In" - last-checkin-string)] - [result (system* (build-path rcs-pathname "ci") - "-u" (string-append "-m" msg) filename)]) - (set! last-checkin-string (or msg "")) - (if result - (send edit load-file - (send edit get-filename) - (send edit get-file-format)) - (mred:gui-utils:message-box "Checkin Unsucessful")))] - [locked? (mred:gui-utils:message-box "Someone else has the lock")] - [else - (let ([current-dir (current-directory)]) - (let-values ([(base name _) (split-path filename)]) - (unless (eq? 'relative base) - (current-directory base)) - (let ([res (system* (build-path rcs-pathname "co") - "-q" "-l" name)]) - (current-directory current-dir) - (if res - (send edit load-file - (send edit get-filename) - (send edit get-file-format)) - (wx:message-box "Checkout Failed")))))]))))))))] - [save-file-as - (lambda (edit event) - (let ([file (mred:finder:put-file)]) - (if file - (send edit save-file file))) - #t)] - [save-file - (lambda (edit event) - (if (null? (send edit get-filename)) - (save-file-as edit event) - (send edit save-file)) - #t)] - [load-file - (lambda (edit event) - (mred:handler:open-file) - #t)]) - (lambda (kmap) - (map (lambda (k) (send kmap implies-shift k)) shifted-key-list) - (let* ([map (lambda (key func) - (send kmap map-function key func))] - [map-meta (lambda (key func) - (send-map-function-meta kmap key func))] - [add (lambda (name func) - (send kmap add-key-function name func))] - [add-m (lambda (name func) - (send kmap add-mouse-function name func))]) - - (add "rcs" rcs) - - (add "save-file" save-file) - (add "save-file-as" save-file-as) - (add "load-file" load-file) - - (when (eq? wx:platform 'unix) - '(map "c:x;c:q" "rcs")) - (map "c:x;c:s" "save-file") - (map "d:s" "save-file") - (map "c:x;c:w" "save-file-as") - (map "c:x;c:f" "load-file"))))) - - ; This installs the standard keyboard mapping - (define setup-global-keymap - ; Define some useful keyboard functions - (let* ([ring-bell - (lambda (edit event) - (let ([c (send edit get-canvas)]) - (when c - (let ([f (let loop ([f c]) - (if (is-a? f wx:frame%) - f - (loop (send f get-parent))))]) - (send f hide-search)))) - (wx:bell))] - - [toggle-anchor - (lambda (edit event) - (send edit set-anchor - (not (send edit get-anchor))))] - [center-view-on-line - (lambda (edit event) - (let ([new-mid-line (send edit position-line - (send edit get-start-position))] - [bt (box 0)] - [bb (box 0)]) - (send edit get-visible-line-range bt bb) - (let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))] - [top-pos (send edit line-start-position - (max (- new-mid-line half) 0))] - [bottom-pos (send edit line-start-position - (min (+ new-mid-line half) - (send edit position-line - (send edit last-position))))]) - (send edit scroll-to-position - top-pos - #f - bottom-pos))) - #t)] - [flash-paren-match - (lambda (edit event) - (send edit on-default-char event) - (let ([pos (mred:scheme-paren:scheme-backward-match - edit - (send edit get-start-position) - 0)]) - (when pos - (send edit flash-on pos (+ 1 pos)))) - #t)] - [collapse-variable-space - (lambda (leave-one? edit event) - (letrec ([find-nonwhite - (lambda (pos d) - (let ([c (send edit get-character pos)]) - (cond - [(char=? #\newline c) pos] - [(char-whitespace? c) - (find-nonwhite (+ pos d) d)] - [else pos])))]) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (if (= sel-start sel-end) - (let ([start (+ (find-nonwhite (- sel-start 1) -1) - (if leave-one? 2 1))] - [end (find-nonwhite sel-start 1)]) - (if (< start end) - (begin - (send edit begin-edit-sequence) - (send edit delete start end) - (if (and leave-one? - (not (char=? #\space - (send edit get-character - (sub1 start))))) - (send edit insert " " (sub1 start) start)) - (send edit set-position start) - (send edit end-edit-sequence)) - (if leave-one? - (let ([at-start - (send edit get-character sel-start)] - [after-start - (send edit get-character - (sub1 sel-start))]) - (cond - [(char-whitespace? at-start) - (if (not (char=? at-start #\space)) - (send edit insert " " sel-start - (add1 sel-start))) - (send edit set-position (add1 sel-start))] - [(char-whitespace? after-start) - (if (not (char=? after-start #\space)) - (send edit insert " " (sub1 sel-start) - sel-start))] - [else (send edit insert " ")])))))))))] - - [collapse-space - (lambda (edit event) - (collapse-variable-space #t edit event))] - - [remove-space - (lambda (edit event) - (collapse-variable-space #f edit event))] - - [collapse-newline - (lambda (edit event) - (letrec ([find-nonwhite - (lambda (pos d offset) - (call/ec - (lambda (escape) - (let ([max (if (> offset 0) - (send edit last-position) - -1)]) - (let loop ([pos pos]) - (if (= pos max) - (escape pos) - (let ([c (send edit get-character - (+ pos offset))]) - (cond - [(char=? #\newline c) - (loop (+ pos d)) - (escape pos)] - [(char-whitespace? c) - (loop (+ pos d))] - [else pos]))))))))]) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (if (= sel-start sel-end) - (let* ([pos-line - (send edit position-line sel-start #f)] - [pos-line-start - (send edit line-start-position pos-line)] - [pos-line-end - (send edit line-end-position pos-line)] - - [whiteline? - (let loop ([pos pos-line-start]) - (if (>= pos pos-line-end) - #t - (and (char-whitespace? - (send edit get-character pos)) - (loop (add1 pos)))))] - - [start (find-nonwhite pos-line-start -1 -1)] - [end (find-nonwhite pos-line-end 1 0)] - - [start-line - (send edit position-line start #f)] - [start-line-start - (send edit line-start-position start-line)] - [end-line - (send edit position-line end #f)] - [end-line-start - (send edit line-start-position (add1 end-line))]) - (cond - [(and whiteline? - (= start-line pos-line) - (= end-line pos-line)) - ; Special case: just delete this line - (send edit delete pos-line-start (add1 pos-line-end))] - [(and whiteline? (< start-line pos-line)) - ; Can delete before & after - (send* edit - (begin-edit-sequence) - (delete (add1 pos-line-end) end-line-start) - (delete start-line-start pos-line-start) - (end-edit-sequence))] - [else - ; Only delete after - (send edit delete (add1 pos-line-end) - end-line-start)]))))))] - - [open-line - (lambda (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (if (= sel-start sel-end) - (send* edit - (insert #\newline) - (set-position sel-start)))))] - - [transpose-chars - (lambda (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (when (= sel-start sel-end) - (let ([sel-start - (if (= sel-start - (send edit line-end-position - (send edit position-line sel-start))) - (sub1 sel-start) - sel-start)]) - (let ([s (send edit get-text - sel-start (add1 sel-start))]) - (send* edit - (begin-edit-sequence) - (delete sel-start (add1 sel-start)) - (insert s (- sel-start 1)) - (set-position (add1 sel-start)) - (end-edit-sequence)))))))] - - [transpose-words - (lambda (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (when (= sel-start sel-end) - (let ([word-1-start (box sel-start)]) - (send edit find-wordbreak word-1-start () - wx:const-break-for-caret) - (let ([word-1-end (box (unbox word-1-start))]) - (send edit find-wordbreak () word-1-end - wx:const-break-for-caret) - (let ([word-2-end (box (unbox word-1-end))]) - (send edit find-wordbreak () word-2-end - wx:const-break-for-caret) - (let ([word-2-start (box (unbox word-2-end))]) - (send edit find-wordbreak word-2-start () - wx:const-break-for-caret) - (let ([text-1 (send edit get-text - (unbox word-1-start) - (unbox word-1-end))] - [text-2 (send edit get-text - (unbox word-2-start) - (unbox word-2-end))]) - (send* edit - (begin-edit-sequence) - (insert text-1 - (unbox word-2-start) - (unbox word-2-end)) - (insert text-2 - (unbox word-1-start) - (unbox word-1-end)) - (set-position (unbox word-2-end)) - (end-edit-sequence))))))))))] - - [capitalize-it - (lambda (edit all? char-case char-case2) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)] - [real-end (send edit last-position)]) - (when (= sel-start sel-end) - (let ([end-box (box sel-start)]) - (send edit find-wordbreak () end-box - wx:const-break-for-caret) - (dynamic-wind - (lambda () - (send edit begin-edit-sequence)) - (lambda () - (let loop ([pos sel-start][char-case char-case]) - (if (< pos real-end) - (let ([c (send edit get-character pos)]) - (if (char-alphabetic? c) - (begin - (send edit insert - (list->string - (list (char-case c))) - pos (add1 pos)) - (if (and all? (< (add1 pos) - (unbox end-box))) - (loop (add1 pos) char-case2))) - (loop (add1 pos) char-case)))))) - (lambda () - (send edit end-edit-sequence))) - (send edit set-position (unbox end-box))))))] - - [capitalize-word - (lambda (edit event) - (capitalize-it edit #t char-upcase char-downcase))] - [upcase-word - (lambda (edit event) - (capitalize-it edit #t char-upcase char-upcase))] - [downcase-word - (lambda (edit event) - (capitalize-it edit #t char-downcase char-downcase))] - - [kill-word - (lambda (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (let ([end-box (box sel-end)]) - (send edit find-wordbreak () end-box - wx:const-break-for-caret) - (send edit kill 0 sel-start (unbox end-box)))))] - - [backward-kill-word - (lambda (edit event) - (let ([sel-start (send edit get-start-position)] - [sel-end (send edit get-end-position)]) - (let ([start-box (box sel-start)]) - (send edit find-wordbreak start-box () - wx:const-break-for-caret) - (send edit kill 0 (unbox start-box) sel-end))))] - - [region-click - (lambda (edit event f) - (when (send event button-down?) - (let ([x-box (box (send event get-x))] - [y-box (box (send event get-y))] - [eol-box (box #f)]) - (send edit global-to-local x-box y-box) - (let ([click-pos (send edit find-position - (unbox x-box) - (unbox y-box) - eol-box)] - [start-pos (send edit get-start-position)] - [end-pos (send edit get-end-position)]) - (let ([eol (unbox eol-box)]) - (if (< start-pos click-pos) - (f click-pos eol start-pos click-pos) - (f click-pos eol click-pos end-pos)))))))] - [copy-click-region - (lambda (edit event) - (region-click edit event - (lambda (click eol start end) - (send edit flash-on start end) - (send edit copy #f 0 start end))))] - [cut-click-region - (lambda (edit event) - (region-click edit event - (lambda (click eol start end) - (send edit cut #f 0 start end))))] - [paste-click-region - (lambda (edit event) - (region-click edit event - (lambda (click eol start end) - (send edit set-position click) - (send edit paste 0 click))))] - - [mouse-copy-clipboard - (lambda (edit event) - (send edit copy #f (send event get-time-stamp)))] - - [mouse-paste-clipboard - (lambda (edit event) - (send edit paste (send event get-time-stamp)))] - - [mouse-cut-clipboard - (lambda (edit event) - (send edit cut #f (send event get-time-stamp)))] - - [select-click-word - (lambda (edit event) - (region-click edit event - (lambda (click eol start end) - (let ([start-box (box click)] - [end-box (box click)]) - (send edit find-wordbreak - start-box - end-box - wx:const-break-for-selection) - (send edit set-position - (unbox start-box) - (unbox end-box))))))] - [select-click-line - (lambda (edit event) - (region-click edit event - (lambda (click eol start end) - (let* ([line (send edit position-line - click eol)] - [start (send edit line-start-position - line #f)] - [end (send edit line-end-position - line #f)]) - (send edit set-position start end)))))] - - [goto-line - (lambda (edit event) - (let ([num-str (mred:gui-utils:get-text-from-user - "Goto Line:" - "Goto Line")]) - (if (string? num-str) - (let ([line-num (string->number num-str)]) - (if line-num - (let ([pos (send edit line-start-position - (sub1 line-num))]) - (send edit set-position pos)))))) - #t)] - [goto-position - (lambda (edit event) - (let ([num-str (mred:gui-utils:get-text-from-user - "Goto Position:" - "Goto Position")]) - (if (string? num-str) - (let ([pos (string->number num-str)]) - (if pos - (send edit set-position (sub1 pos)))))) - #t)] - [repeater - (lambda (n edit) - (let* ([km (send edit get-keymap)] - [done - (lambda () - (send km set-break-sequence-callback void) - (send km remove-grab-key-function))]) - (send km set-grab-key-function - (lambda (name local-km edit event) - (if (null? name) - (let ([k (send event get-key-code)]) - (if (<= (char->integer #\0) k (char->integer #\9)) - (set! n (+ (* n 10) (- k (char->integer #\0)))) - (begin - (done) - (dynamic-wind - (lambda () - (send edit begin-edit-sequence)) - (lambda () - (let loop ([n n]) - (unless (zero? n) - (send edit on-char event) - (loop (sub1 n))))) - (lambda () - (send edit end-edit-sequence)))))) - (begin - (done) - (dynamic-wind - (lambda () - (send edit begin-edit-sequence)) - (lambda () - (let loop ([n n]) - (unless (zero? n) - (send local-km call-function name edit event) - (loop (sub1 n))))) - (lambda () - (send edit end-edit-sequence))))) - #t)) - (send km set-break-sequence-callback done) - #t))] - [make-make-repeater - (lambda (n) - (lambda (edit event) - (repeater n edit)))] - [current-macro '()] - [building-macro #f] [build-macro-km #f] [build-protect? #f] - [do-macro - (lambda (edit event) - ; If c:x;e during record, copy the old macro - (when building-macro - (set! building-macro (append (reverse current-macro) - (cdr building-macro)))) - (let ([bm building-macro] - [km (send edit get-keymap)]) - (dynamic-wind - (lambda () - (set! building-macro #f) - (send edit begin-edit-sequence)) - (lambda () - (let/ec escape - (for-each - (lambda (f) - (let ([name (car f)] - [event (cdr f)]) - (if (null? name) - (send edit on-char event) - (if (not (send km call-function - name edit event #t)) - (escape #t))))) - current-macro))) - (lambda () - (send edit end-edit-sequence) - (set! building-macro bm)))) - #t)] - [start-macro - (lambda (edit event) - (if building-macro - (send build-macro-km break-sequence) - (letrec* ([km (send edit get-keymap)] - [done - (lambda () - (if build-protect? - (send km set-break-sequence-callback done) - (begin - (set! building-macro #f) - (send km set-break-sequence-callback void) - (send km remove-grab-key-function))))]) - (set! building-macro '()) - (set! build-macro-km km) - (send km set-grab-key-function - (lambda (name local-km edit event) - (dynamic-wind - (lambda () - (set! build-protect? #t)) - (lambda () - (if (null? name) - (send edit on-default-char event) - (send local-km call-function name edit event))) - (lambda () - (set! build-protect? #f))) - (when building-macro - (set! building-macro - (cons (cons name - (duplicate-key-event event)) - building-macro))) - #t)) - (send km set-break-sequence-callback done))) - #t)] - [end-macro - (lambda (edit event) - (when building-macro - (set! current-macro (reverse building-macro)) - (set! build-protect? #f) - (send build-macro-km break-sequence)) - #t)] - [delete-key - (lambda (edit event) - (let ([kmap (send edit get-keymap)]) - (send kmap call-function - (if (mred:preferences:get-preference 'mred:delete-forward?) - "delete-next-character" - "delete-previous-character") - edit event #t)))] - [toggle-overwrite - (lambda (edit event) - (send edit set-overwrite-mode - (not (send edit get-overwrite-mode))))]) - (lambda (kmap) - ; Redirect keymapping error messages to stderr - (send kmap set-error-callback keyerr) - ; Set the implied shifting map - (map (lambda (k) (send kmap implies-shift k)) shifted-key-list) - (let* ([map (lambda (key func) - (send kmap map-function key func))] - [map-meta (lambda (key func) - (send-map-function-meta kmap key func))] - [add (lambda (name func) - (send kmap add-key-function name func))] - [add-m (lambda (name func) - (send kmap add-mouse-function name func))]) - - ; Standards - (wx:add-media-buffer-functions kmap) - (wx:add-media-editor-functions kmap) - (wx:add-media-pasteboard-functions kmap) - - ; Map names to keyboard functions - (add "toggle-overwrite" toggle-overwrite) - - (add "exit" (lambda (edit event) - (let ([frame (send edit get-frame)]) - (if frame - ((ivar frame file-menu:quit)) - (wx:bell))))) - - (add "ring-bell" ring-bell) - - (add "flash-paren-match" flash-paren-match) - - (add "toggle-anchor" toggle-anchor) - (add "center-view-on-line" center-view-on-line) - (add "collapse-space" collapse-space) - (add "remove-space" remove-space) - (add "collapse-newline" collapse-newline) - (add "open-line" open-line) - (add "transpose-chars" transpose-chars) - (add "transpose-words" transpose-words) - (add "capitalize-word" capitalize-word) - (add "upcase-word" upcase-word) - (add "downcase-word" downcase-word) - (add "kill-word" kill-word) - (add "backward-kill-word" backward-kill-word) - - (let loop ([n 9]) - (unless (negative? n) - (let ([s (number->string n)]) - (add (string-append "command-repeat-" s) - (make-make-repeater n)) - (loop (sub1 n))))) - - (add "do-saved-macro" do-macro) - (add "start-macro-record" start-macro) - (add "end-macro-record" end-macro) - - (add-m "copy-clipboard" mouse-copy-clipboard) - (add-m "cut-clipboard" mouse-cut-clipboard) - (add-m "paste-clipboard" mouse-paste-clipboard) - (add-m "copy-click-region" copy-click-region) - (add-m "cut-click-region" cut-click-region) - (add-m "paste-click-region" paste-click-region) - (add-m "select-click-word" select-click-word) - (add-m "select-click-line" select-click-line) - - (add "goto-line" goto-line) - (add "goto-position" goto-position) - - (add "delete-key" delete-key) - - ; Map keys to functions - (map "c:g" "ring-bell") - (map-meta "c:g" "ring-bell") - (map "c:x;c:g" "ring-bell") - (map "c:c;c:g" "ring-bell") - - (map ")" "flash-paren-match") - (map "]" "flash-paren-match") - (map "}" "flash-paren-match") - (map "\"" "flash-paren-match") - - (map "c:p" "previous-line") - (map "up" "previous-line") - (map "s:c:p" "select-up") - (map "s:up" "select-up") - - (map "c:n" "next-line") - (map "down" "next-line") - (map "s:c:n" "select-down") - (map "s:down" "select-down") - - (map "c:e" "end-of-line") - (map "d:RIGHT" "end-of-line") - (map "m:RIGHT" "end-of-line") - (map "END" "end-of-line") - (map "d:s:RIGHT" "select-to-end-of-line") - (map "m:s:RIGHT" "select-to-end-of-line") - (map "s:END" "select-to-end-of-line") - (map "s:c:e" "select-to-end-of-line") - - (map "c:a" "beginning-of-line") - (map "d:LEFT" "beginning-of-line") - (map "m:LEFT" "beginning-of-line") - (map "HOME" "beginning-of-line") - (map "d:s:LEFT" "select-to-beginning-of-line") - (map "m:s:LEFT" "select-to-beginning-of-line") - (map "s:HOME" "select-to-beginning-of-line") - (map "s:c:a" "select-to-beginning-of-line") - - (map "c:f" "forward-character") - (map "right" "forward-character") - (map "s:c:f" "forward-select") - (map "s:right" "forward-select") - - (map "c:b" "backward-character") - (map "left" "backward-character") - (map "s:c:b" "backward-select") - (map "s:left" "backward-select") - - (map-meta "f" "forward-word") - (map "a:RIGHT" "forward-word") - (map "c:RIGHT" "forward-word") - (map-meta "s:f" "forward-select-word") - (map "a:s:RIGHT" "forward-select-word") - (map "c:s:RIGHT" "forward-select-word") - - (map-meta "b" "backward-word") - (map "a:LEFT" "backward-word") - (map "c:left" "backward-word") - (map-meta "s:b" "backward-select-word") - (map "a:s:LEFT" "backward-select-word") - (map "c:s:left" "backward-select-word") - - (map-meta "<" "beginning-of-file") - (map "d:UP" "beginning-of-file") - (map "c:HOME" "beginning-of-file") - (map "s:c:home" "select-to-beginning-of-file") - (map "s:d:up" "select-to-beginning-of-file") - - (map-meta ">" "end-of-file") - (map "d:DOWN" "end-of-file") - (map "c:end" "end-of-file") - (map "s:c:end" "select-to-end-of-file") - (map "s:d:down" "select-to-end-of-file") - - (map "c:v" "next-page") - (map "a:DOWN" "next-page") - (map "pagedown" "next-page") - (map "c:DOWN" "next-page") - (map "s:c:v" "select-page-down") - (map "a:s:DOWN" "select-page-down") - (map "s:pagedown" "select-page-down") - (map "s:c:DOWN" "select-page-down") - - (map-meta "v" "previous-page") - (map "a:up" "previous-page") - (map "pageup" "previous-page") - (map "c:up" "previous-page") - (map-meta "s:v" "select-page-up") - (map "s:a:up" "select-page-up") - (map "s:pageup" "select-page-up") - (map "s:c:up" "select-page-up") - - (map "c:h" "delete-previous-character") - (map "c:d" "delete-next-character") - (map "del" "delete-key") - - (map-meta "d" "kill-word") - (map-meta "del" "backward-kill-word") - (map-meta "c" "capitalize-word") - (map-meta "u" "upcase-word") - (map-meta "l" "downcase-word") - - (map "c:l" "center-view-on-line") - - (map "c:k" "delete-to-end-of-line") - (map "c:y" "paste-clipboard") - (map-meta "y" "paste-next") - (map "a:v" "paste-clipboard") - (map "d:v" "paste-clipboard") - (map "c:_" "undo") - (map "c:+" "redo") - (map "a:z" "undo") - (map "d:z" "undo") - (map "c:x;u" "undo") - (map "c:w" "cut-clipboard") - (map "a:x" "cut-clipboard") - (map "d:x" "cut-clipboard") - (map-meta "w" "copy-clipboard") - (map "a:c" "copy-clipboard") - (map "d:c" "copy-clipboard") - - (map-meta "space" "collapse-space") - (map-meta "\\" "remove-space") - (map "c:x;c:o" "collapse-newline") - (map "c:o" "open-line") - (map "c:t" "transpose-chars") - (map-meta "t" "transpose-words") - - (map "c:space" "toggle-anchor") - - (map "insert" "toggle-overwrite") - (map-meta "o" "toggle-overwrite") - - (map-meta "g" "goto-line") - (map-meta "p" "goto-position") - - (map "c:u" "command-repeat-0") - (let loop ([n 9]) - (unless (negative? n) - (let ([s (number->string n)]) - (map-meta s (string-append "command-repeat-" s)) - (loop (sub1 n))))) - - (map "c:x;e" "do-saved-macro") - (map "c:x;(" "start-macro-record") - (map "c:x;)" "end-macro-record") - - (map "leftbuttontriple" "select-click-line") - (map "leftbuttondouble" "select-click-word") - - (map "c:x;c:c" "exit") - - (map "rightbutton" "copy-click-region") - (map "rightbuttondouble" "cut-click-region") - (map "middlebutton" "paste-click-region") - (map "c:rightbutton" "copy-clipboard"))))) - - (define global-keymap (make-object wx:keymap%)) - (setup-global-keymap global-keymap) - - (define global-file-keymap (make-object wx:keymap%)) - (setup-global-file-keymap global-file-keymap) - - (define global-search-keymap (make-object wx:keymap%)) - (setup-global-search-keymap global-search-keymap)) diff --git a/collects/mred/panel.ss b/collects/mred/panel.ss deleted file mode 100644 index 8729a4d4..00000000 --- a/collects/mred/panel.ss +++ /dev/null @@ -1,82 +0,0 @@ - - (unit/sig mred:panel^ - (import mred:wx^ - [mred:constants : mred:constants^] - [mred:container : mred:container^] - [mred:canvas : mred:canvas^] - mzlib:function^) - - (mred:debug:printf 'invoke "mred:panel@") - - (define make-edit-panel% - (lambda (super%) - (class-asi super% - (rename [super-change-children change-children]) - (inherit get-parent change-children children) - (public [get-canvas% (lambda () mred:canvas:frame-title-canvas%)]) - (public - [collapse - (lambda (canvas) - (letrec* ([media (send canvas get-media)] - [helper - (lambda (canvas/panel) - (if (eq? canvas/panel this) - (begin (cond - [(and (= (length children) 1) - (eq? canvas (car children))) - (void)] - [(member canvas children) - (change-children (lambda (l) (list canvas)))] - [else - (change-children - (lambda (l) - (let ([c (make-object (object-class canvas) this)]) - (send c set-media media) - (list c))))]) - (wx:bell)) - (let* ([parent (send canvas/panel get-parent)] - [parents-children (ivar parent children)] - [num-children (length parents-children)]) - (if (<= num-children 1) - (helper parent) - (begin (send parent delete-child canvas/panel) - (send (car (ivar parent children)) set-focus))))))]) - (send media remove-canvas canvas) - (helper canvas)))] - - [split - (opt-lambda (canvas [panel% mred:container:horizontal-panel%]) - (let* ([frame (ivar canvas frame)] - [media (send canvas get-media)] - [canvas% (object-class canvas)] - [parent (send canvas get-parent)] - [new-panel #f] - [left-split #f] - [right-split #f] - [before #t]) - (dynamic-wind - (lambda () - (set! before (send frame delay-updates)) - (send frame delay-updates #t)) - (lambda () - (set! new-panel (make-object panel% parent)) - (set! left-split (make-object canvas% new-panel)) - (set! right-split (make-object canvas% new-panel)) - (send parent change-children - (lambda (l) - (let ([before (remq new-panel l)]) - (map (lambda (x) (if (eq? x canvas) - new-panel - x)) - before))))) - (lambda () (send frame delay-updates before))) - (send* media (remove-canvas canvas) - (add-canvas left-split) - (add-canvas right-split)) - (send* left-split (set-media media) (set-focus)) - (send* right-split (set-media media))))])))) - - (define horizontal-edit-panel% - (make-edit-panel% mred:container:horizontal-panel%)) - (define vertical-edit-panel% - (make-edit-panel% mred:container:vertical-panel%))) \ No newline at end of file diff --git a/collects/mred/prefs.ss b/collects/mred/prefs.ss deleted file mode 100644 index 8e8dab8b..00000000 --- a/collects/mred/prefs.ss +++ /dev/null @@ -1,562 +0,0 @@ -;; need a preference for pconvert - - (unit/sig mred:preferences^ - (import mred:wx^ - [mred:constants : mred:constants^] - [mred:exn : mred:exn^] - [mred : mred:container^] - [mred:exit : mred:exit^] - [mred:gui-utils : mred:gui-utils^] - [mred:edit : mred:edit^] - [mzlib:pretty-print : mzlib:pretty-print^] - [mzlib:function : mzlib:function^]) - - (mred:debug:printf 'invoke "mred:preferences@") - - (define preferences-filename (wx:find-path 'pref-file)) - - (define preferences (make-hash-table)) - (define marshall-unmarshall (make-hash-table)) - (define callbacks (make-hash-table)) - (define defaults (make-hash-table)) - - (define-struct un/marshall (marshall unmarshall)) - (define-struct marshalled (data)) - (define-struct pref (value)) - (define-struct default (value checker)) - - (define guard - (lambda (when p value thunk) - (let ([h - (lambda (x) - (let ([msg - (format "exception raised ~a for ~a with ~a: ~a~n" - when p value - (exn-message x))]) - (raise (mred:exn:make-exn:during-preferences - msg - ((debug-info-handler))))))]) - - (with-handlers ([(lambda (x) #t) h]) - (thunk))))) - - (define unmarshall - (lambda (p marshalled) - (let/ec k - (let* ([data (marshalled-data marshalled)] - [unmarshall-fn (un/marshall-unmarshall (hash-table-get marshall-unmarshall - p - (lambda () (k data))))]) - (guard "unmarshalling" p marshalled - (lambda () (unmarshall-fn data))))))) - - (define get-callbacks - (lambda (p) - (hash-table-get callbacks - p - (lambda () null)))) - - (define add-preference-callback - (lambda (p callback) - (hash-table-put! callbacks p (append (get-callbacks p) (list callback))) - (lambda () - (hash-table-put! - callbacks p - (mzlib:function:remove callback - (get-callbacks p) - eq?))))) - - (define check-callbacks - (lambda (p value) - (andmap (lambda (x) - (guard "calling callback" p value - (lambda () (x p value)))) - (get-callbacks p)))) - - (define get-preference - (lambda (p) - (let ([ans (hash-table-get preferences p - (lambda () - (raise (mred:exn:make-exn:unknown-preference - (format "attempted to get unknown preference: ~a" p) - ((debug-info-handler))))))]) - (cond - [(marshalled? ans) - (let* ([default-s - (hash-table-get - defaults p - (lambda () - (error 'get-preference - "no default pref for: ~a~n" - p)))] - [default (default-value default-s)] - [checker (default-checker default-s)] - [unmarshalled (let ([unmarsh (unmarshall p ans)]) - (if (checker unmarsh) - unmarsh - (begin - (printf "WARNING: ~s rejecting invalid pref ~s in favor of ~s~n" - p unmarsh default) - default)))] - [_ (mred:debug:printf 'prefs "get-preference checking callbacks: ~a to ~a" - p unmarshalled)] - [pref (if (check-callbacks p unmarshalled) - unmarshalled - default)]) - (hash-table-put! preferences p (make-pref pref)) - (mred:debug:printf 'prefs "get-preference.1 returning ~a as ~a" - p pref) - pref)] - [(pref? ans) - (let ([ans (pref-value ans)]) - (mred:debug:printf 'prefs "get-preference.2 returning ~a as ~a" - p ans) - ans)] - [else (error 'prefs.ss "robby error.1: ~a" ans)])))) - - (define set-preference - (lambda (p value) - (let* ([pref (hash-table-get preferences p (lambda () #f))]) - (cond - [(pref? pref) - (mred:debug:printf 'prefs "set-preference.1 checking callbacks: ~a to ~a" p value) - (when (check-callbacks p value) - (mred:debug:printf 'prefs "set-preference.1 setting ~a to ~a" - p value) - (set-pref-value! pref value))] - [(or (marshalled? pref) - (not pref)) - (mred:debug:printf 'prefs "set-preference.2 checking callbacks: ~a to ~a" p value) - (when (check-callbacks p value) - (mred:debug:printf 'prefs "set-preference.2 setting ~a to ~a" - p value) - (hash-table-put! preferences p (make-pref value)))] - [else - (error 'prefs.ss "robby error.0: ~a" pref)])))) - - (define set-preference-un/marshall - (lambda (p marshall unmarshall) - (hash-table-put! marshall-unmarshall p (make-un/marshall marshall unmarshall)))) - - (define restore-defaults - (lambda () - (mred:debug:printf 'prefs "setting prefs to default values") - (hash-table-for-each - defaults - (lambda (p v) (set-preference p v))) - (mred:debug:printf 'prefs "finished setting prefs to default values"))) - - (define set-preference-default - (lambda (p value checker) - (mred:debug:printf 'prefs "setting default value for ~a to ~a" p value) - (hash-table-get preferences p - (lambda () - (hash-table-put! preferences p (make-pref value)))) - (hash-table-put! defaults p (make-default value checker)))) - - ;; this is here becuase exit has to come before - ;; prefs.ss in the loading order. - (set-preference-default 'mred:verify-exit #t - (lambda (x) - (or (not x) - (eq? x #t)))) - - (define save-user-preferences - (let ([marshall-pref - (lambda (p ht-value) - (cond - [(marshalled? ht-value) (list p (marshalled-data ht-value))] - [(pref? ht-value) - (let* ([value (pref-value ht-value)] - [marshalled - (let/ec k - (guard "marshalling" p value - (lambda () - ((un/marshall-marshall - (hash-table-get marshall-unmarshall p - (lambda () - (k value)))) - value))))]) - (list p marshalled))] - [else (error 'prefs.ss "robby error.2: ~a" ht-value)]))]) - (lambda () - (mred:debug:printf 'prefs "saving user preferences") - (with-handlers ([(lambda (x) #t) - (lambda (exn) - (mred:gui-utils:message-box - (format "Error saving preferences~n~a" - (exn-message exn)) - "Error saving preferences"))]) - (call-with-output-file preferences-filename - (lambda (p) - (mzlib:pretty-print:pretty-print - (hash-table-map preferences marshall-pref) p)) - 'truncate 'text)) - (mred:debug:printf 'prefs "saved user preferences")))) - - (mred:exit:insert-exit-callback - (lambda () - (with-handlers ([(lambda (x) #t) - (lambda (exn) - (mred:gui-utils:message-box - (format "Error saving preferences: ~a" - (exn-message exn)) - "Saving Prefs"))]) - (save-user-preferences)))) - - (define read-user-preferences - (let ([parse-pref - (lambda (p marshalled) - (let/ec k - (let* ([ht-pref (hash-table-get preferences p (lambda () #f))] - [unmarshall-struct (hash-table-get marshall-unmarshall p (lambda () #f))]) - (mred:debug:printf 'prefs "read-user-preferences; p: ~a ht-pref: ~a; marshalled: ~a" - p ht-pref marshalled) - (cond - [(and (pref? ht-pref) unmarshall-struct) - (set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))] - - ;; in this case, assume that no marshalling/unmarshalling - ;; is going to take place with the pref, since an unmarshalled - ;; pref was already there. - [(pref? ht-pref) - (set-preference p marshalled)] - - [(marshalled? ht-pref) (set-marshalled-data! ht-pref marshalled)] - [(and (not ht-pref) unmarshall-struct) - (set-preference p ((un/marshall-unmarshall unmarshall-struct) marshalled))] - [(not ht-pref) - (hash-table-put! preferences p (make-marshalled marshalled))] - [else (error 'prefs.ss "robby error.3: ~a" ht-pref)]))))]) - (lambda () - (mred:debug:printf 'prefs "reading user preferences") - (let/ec k - (when (file-exists? preferences-filename) - (let ([err - (lambda (input msg) - (wx:message-box (let* ([max-len 150] - [s1 (format "~s" input)] - [ell "..."] - [s2 (if (<= (string-length s1) max-len) - s1 - (string-append (substring s1 0 (- max-len - (string-length ell))) - ell))]) - (format "found bad pref: ~a~n~a" msg s2)) - "Preferences"))]) - (let loop ([input (with-handlers - ([(lambda (exn) #t) - (lambda (exn) - (wx:message-box - (format "Error reading preferences~n~a" - (exn-message exn)) - "Error reading preferences") - (k #f))]) - (call-with-input-file preferences-filename - read - 'text))]) - (cond - [(pair? input) - (let ([err-msg - (let/ec k - (let ([first (car input)]) - (unless (pair? first) - (k "expected pair of pair")) - (let ([arg1 (car first)] - [t1 (cdr first)]) - (unless (pair? t1) - (k "expected pair of two pairs")) - (let ([arg2 (car t1)] - [t2 (cdr t1)]) - (unless (null? t2) - (k "expected null after two pairs")) - (parse-pref arg1 arg2) - (k #f)))))]) - (when err-msg - (err input err-msg))) - (loop (cdr input))] - [(null? input) (void)] - [else (err input "expected a pair")]))))) - (mred:debug:printf 'prefs "read user preferences")))) - - (define-struct ppanel (title container panel)) - - (define font-families (list "Default" "Roman" "Decorative" - "Modern" "Swiss" "Script")) - (define font-size-entry "defaultFontSize") - (define font-default-string "Default Value") - (define font-default-size 12) - (define font-section "mred") - (define build-font-entry (lambda (x) (string-append "Screen" x "__"))) - (define font-file (wx:find-path 'setup-file)) - (define (build-font-preference-symbol family) - (string->symbol (string-append "mred:" family))) - - (let ([set-default - (lambda (build-font-entry default pred) - (lambda (family) - (let ([name (build-font-preference-symbol family)] - [font-entry (build-font-entry family)]) - (set-preference-default name - default - string?) - (add-preference-callback - name - (lambda (p new-value) - (wx:write-resource - font-section - font-entry - (if (and (string? new-value) - (string=? font-default-string new-value)) - "" - new-value) - font-file))))))]) - (for-each (set-default build-font-entry - font-default-string - string?) - font-families) - ((set-default (lambda (x) x) - font-default-size - number?) - font-size-entry)) - - (define ppanels - (list - (make-ppanel - "General" - (lambda (parent) - (let* ([main (make-object mred:vertical-panel% parent)] - [make-check - (lambda (pref title bool->pref pref->bool) - (let* ([callback - (lambda (_ command) - (set-preference pref (bool->pref (send command checked?))))] - [pref-value (get-preference pref)] - [initial-value (pref->bool pref-value)] - [h (make-object mred:horizontal-panel% main)] - [c (make-object mred:check-box% h callback title)] - [p (make-object mred:horizontal-panel% h)]) - (send c set-value initial-value) - (add-preference-callback pref - (lambda (p v) - (send c set-value (pref->bool v))))))] - [id (lambda (x) x)]) - (make-check 'mred:highlight-parens "Highlight between matching parens?" id id) - (make-check 'mred:fixup-parens "Correct parens?" id id) - (make-check 'mred:paren-match "Flash paren match?" id id) - (make-check 'mred:autosaving-on? "Auto-save files?" id id) - (make-check 'mred:delete-forward? "Map delete to backspace?" not not) - (make-check 'mred:file-dialogs "Use platform-specific file dialogs?" - (lambda (x) (if x 'std 'common)) - (lambda (x) (eq? x 'std))) - - (make-check 'mred:verify-exit "Verify exit?" id id) - (make-check 'mred:verify-change-format "Ask before changing save format?" id id) - (make-check 'mred:auto-set-wrap? "Wordwrap editor buffers?" id id) - - (make-check 'mred:show-status-line "Show status-line?" id id) - (make-check 'mred:line-offsets "Count line and column numbers from one?" id id) - (make-check 'mred:menu-bindings "Enable keybindings in menus?" id id) - (unless (eq? wx:platform 'unix) - (make-check 'mred:print-output-mode "Automatically print to postscript file?" - (lambda (b) (if b 1 0)) - (lambda (n) (= n 1)))) - main)) - #f) - (make-ppanel - "Default Fonts" - (lambda (parent) - (let* ([main (make-object mred:vertical-panel% parent)] - [fonts (cons font-default-string (wx:get-font-list))] - [make-family-panel - (lambda (name) - (let* ([pref-sym (build-font-preference-symbol name)] - [horiz (make-object mred:horizontal-panel% main - -1 -1 -1 -1 wx:const-border)] - [label (make-object mred:message% horiz name)] - [space (make-object mred:horizontal-panel% horiz)] - [_ (make-object mred:message% horiz - (let ([b (box "")]) - (if (and (wx:get-resource - font-section - (build-font-entry name) - b) - (not (string=? (unbox b) - ""))) - (unbox b) - font-default-string)))] - [button - (make-object - mred:button% horiz - (lambda (button evt) - (let ([new-value - (mred:gui-utils:get-single-choice - (format "Please choose a new ~a font" - name) - "Fonts" - fonts - null -1 -1 #t 300 400)]) - (unless (null? new-value) - (set-preference pref-sym - new-value)))) - "Change")]) - (add-preference-callback - pref-sym - (lambda (p new-value) - (send horiz change-children - (lambda (l) - (list label space - (make-object - mred:message% - horiz - new-value) - button))))) - (void)))]) - (for-each make-family-panel font-families) - (let ([size-panel (make-object mred:horizontal-panel% main -1 -1 -1 -1 wx:const-border)]) - '(make-object mred:message% size-panel "Size") - '(make-object mred:horizontal-panel% size-panel) - (let* ([sym (build-font-preference-symbol - font-size-entry)] - [size-slider - (make-object mred:slider% size-panel - (lambda (slider evt) - (set-preference sym - (send slider get-value))) - "Size" - (let ([b (box 0)]) - (if (wx:get-resource font-section - font-size-entry - b) - (unbox b) - font-default-size)) - 1 127 50)]) - (add-preference-callback - sym - (lambda (p value) - (unless (= value (send size-slider get-value)) - (send size-slider set-value value)))))) - (make-object mred:message% main - "Restart to see font changes") - main)) - #f))) - - (define make-run-once - (lambda () - (let ([semaphore (make-semaphore 1)]) - (lambda (t) - (dynamic-wind (lambda () (semaphore-wait semaphore)) - t - (lambda () (semaphore-post semaphore))))))) - - (define run-once (make-run-once)) - - (define preferences-dialog #f) - - (define add-preference-panel - (lambda (title container) - (run-once - (lambda () - (let ([new-ppanel (make-ppanel title container #f)]) - (set! ppanels - (let loop ([ppanels ppanels]) - (cond - [(null? ppanels) (list new-ppanel)] - [(string=? (ppanel-title (car ppanels)) - title) - (loop (cdr ppanels))] - [else (cons (car ppanels) - (loop (cdr ppanels)))]))) - (when preferences-dialog - (send preferences-dialog added-pane))))))) - - (define hide-preferences-dialog - (lambda () - (run-once - (lambda () - (when preferences-dialog - (send preferences-dialog show #f)))))) - - (define show-preferences-dialog - (lambda () - (mred:gui-utils:show-busy-cursor - (lambda () - (run-once - (lambda () - (save-user-preferences) - (if preferences-dialog - (send preferences-dialog show #t) - (set! preferences-dialog - (let ([cursor-off (mred:gui-utils:delay-action - 2 wx:begin-busy-cursor - wx:end-busy-cursor)]) - (begin0 (make-preferences-dialog) - (cursor-off))))))))))) - - (define make-preferences-dialog - (lambda () - (letrec* ([frame - (make-object (class-asi mred:frame% - (public [added-pane (lambda () - (ensure-constructed) - (refresh-menu) - (send popup-menu set-selection (sub1 (length ppanels))) - (send single-panel active-child - (ppanel-panel (car (list-tail ppanels (sub1 (length ppanels)))))))])) - '() "Preferences")] - [panel (make-object mred:vertical-panel% frame)] - [top-panel (make-object mred:horizontal-panel% panel)] - [single-panel (make-object mred:single-panel% panel -1 -1 -1 -1 wx:const-border)] - [bottom-panel (make-object mred:horizontal-panel% panel)] - [popup-callback - (lambda (choice command-event) - (send single-panel active-child - (ppanel-panel (list-ref ppanels (send command-event get-command-int)))))] - [make-popup-menu - (lambda () - (let ([menu (make-object mred:choice% top-panel popup-callback - "Category" -1 -1 -1 -1 - (map ppanel-title ppanels))]) - (send menu stretchable-in-x #f) - menu))] - [top-left (make-object mred:vertical-panel% top-panel)] - [popup-menu (make-popup-menu)] - [top-right (make-object mred:vertical-panel% top-panel)] - [ensure-constructed - (lambda () - (for-each (lambda (ppanel) - (unless (ppanel-panel ppanel) - (let ([panel ((ppanel-container ppanel) single-panel)]) - (unless (is-a? panel mred:panel%) - (error 'preferences-dialog - "expected the preference panel to be a mred:panel%. Got ~a instead~n" - panel)) - (set-ppanel-panel! ppanel panel)))) - ppanels) - (send single-panel change-children (lambda (l) (map ppanel-panel ppanels))) - (send single-panel active-child (ppanel-panel (car ppanels))))] - [refresh-menu - (lambda () - (let ([new-popup (make-popup-menu)]) - (send new-popup set-selection (send popup-menu get-selection)) - (set! popup-menu new-popup) - (send top-panel change-children - (lambda (l) (list top-left new-popup top-right)))))] - [ok-callback (lambda args - (save-user-preferences) - (hide-preferences-dialog))] - [_1 (make-object mred:panel% bottom-panel)] - [ok-button (make-object mred:button% bottom-panel ok-callback "OK")] - [cancel-callback (lambda args - (hide-preferences-dialog) - (read-user-preferences))] - [cancel-button (make-object mred:button% bottom-panel cancel-callback "Cancel")]) - (send ok-button user-min-width (send cancel-button get-width)) - (send bottom-panel stretchable-in-y #f) - (send top-panel stretchable-in-y #f) - (ensure-constructed) - (send popup-menu set-selection 0) - (send frame show #t) - frame))) - - (read-user-preferences)) diff --git a/man/man1/mred.1 b/man/man1/mred.1 deleted file mode 100644 index c1c9f730..00000000 --- a/man/man1/mred.1 +++ /dev/null @@ -1,194 +0,0 @@ -\" dummy line -.TH MRED 1 "8 June 1996" -.UC 4 -.SH NAME -mred \- The Rice PLT Scheme GUI engine -.SH SYNOPSIS -.B mred -[-s -.I sysfile -] -[-a -.I unit-filename -.I sig-filename -] -[-w -.I filename -] -[-p -.I image-filename -.I splash-title -.I splash-count -] -[-b ] -[-q | --no-init-file] -[-nu ] -[-f -.I file -] -[-e -.I expr -] -[-- -.I arguments -] -[ -.I file -] -.SH DESCRIPTION -.I MrEd -is the Rice University PLT Scheme GUI -execution engine. -It extends -.I MzScheme -with graphics -and provides the underlying architecture for -.I DrScheme. -.PP -The -s flag directs -.I MrEd -to load the startup system from -a particular file. This overrides the system directory -search path described below in FILES and must come before all other -arguments. -.PP -The -a flag directs -.I MrEd -to look in the first file for a unit/sig (not a -definition of a unit, just a plain unit) and the second file for signatures -that the unit/sig needs. That unit will be used to start a new appliaction -built on top of -.I MrEd. -See the Toolbox manual for more information on how to write your own -application using -.I MrEd. -.PP -The -w flag causes filename to be written over with a Static Debugger -file, which can be used to analyze your application. You must use the -a -flag and have written a Static Debugger conformant application to use this -flag. See the Static Debugger and the Toolbox manuals for more information -on Static Debugger conformancy and the -a flag respectively. -.PP -The -p flag specifies a splash screen filename. The splash screen must be -an image file supported by wx:bitmap% objects. See the Toolbox manual for more -information on what image types are supported by wx:bitmap% objects. The -second argument to -p names the splash screen, and the third is a count -indicating how many files will be loaded. -.PP -The -b flags supresses the splash screen. -.PP -The -q or --no-init-file flag prevents -.I MrEd -from loading -the user's startup file ".mredrc" in the user's home -directory. -.PP -multiple -f -and -e flags can be specified. For each -e flag, the corresponding -expression is evaluated. For each -f flag, the corresponding file -is loaded (with its directory as the working cirectory). -.PP -If a file appears on the command line with no switches, then it is opened -for editing in -.I MrEd. -The -- flag means to treat the next argument as a file -to be opened for editing, even if it is "-e" or "-f". -.PP -The -nu flag specifies a non-unit startup. See the Toolbox Manual for more -details on -.I MrEd's -startup and how to build your own application with -.I MrEd. -.PP -Once all command line arguments are handled the scheme procedure -mred:startup is called. This procedure is defined by the standard -system, but it can be redefined with the -f or -e flags for -application-specific startup sequences. -.PP -For further information on -.I MrEd, -please consult the on-line -documentation in the Help menu of the console -and other information available at -.PP -.ce 1 -http://www.cs.rice.edu/CS/PLT/packages/mred/ - -.SH FILES -If the -s flag is not specified, -.I MrEd -looks for its standard system file "mrsystem.ss" with the following -search path: -.IP -* the search path defined by the MREDSYS system evironment -variable -.IP -* "$PLTHOME/mred/system" -.IP -* "/usr/local/lib/plt/mred/system" -.IP -* "/usr/lib/plt/mred/system" -.IP -* "/usr/local/lib/mred/system" -.IP -* "/usr/lib/mred/system" -.PP - -The standard system finds the -.I MrEd -collections directory and loads the -.I MrEd -library. The -I. MrEd -collections directory is -"../mred/collects" relative to the system's directory. - -The standard system also finds the -.I MzScheme -collection -directory and loads the core -.I MzLib -library. The -.I MzScheme -collection directory is found with -the following search path: -.IP -* "$PLTHOME/mzscheme/collects/standard" (if PLTHOME is not defined, -/usr/local/lib/ is used as it's value). -.IP -* "../mzscheme/collects/" relative to the system's directory -.IP -* "../../mzscheme/collects/standard" relative to the system's directory -.IP -.PP - -The `require-library-collections-paths' parameter is set -to a list containing the -.I MzScheme -collections -directory and the -.I MrEd -collections directory. - -.I MrEd -also looks for Xresources in -.IP -* "~/.mred.resources" -.PP -Xresources in that file override any other resources settings. - -.SH BUGS -Submit bug reports via -.ce 1 -http://www.cs.rice.edu/CS/PLT/Gnats/ (encouraged) -or by e-mail to -.ce 1 -plt-bugs@cs.rice.edu (discouraged) -.SH AUTHOR -.I MrEd -was implemented by Matthew Flatt (mflatt@cs.rice.edu) and Robby Findler -(robby@cs.rice.edu) using wxWindows by Julian Smart et al. and -the conservative garbage collector by Hans Boehm et al. -.SH SEE ALSO -.BR drscheme(1), -.BR mzscheme(1) diff --git a/man/man1/mzscheme.1 b/man/man1/mzscheme.1 deleted file mode 100644 index 804a59db..00000000 --- a/man/man1/mzscheme.1 +++ /dev/null @@ -1,209 +0,0 @@ -.\" dummy line -.TH MZSCHEME 1 "31 May 1997" -.UC 4 -.SH NAME -mzscheme \- The PLT Scheme implementation -.SH SYNOPSIS -.B mzscheme -[ -.I flags -] [ -.I arguments -] -.SH DESCRIPTION -.I MzScheme -is the Rice University PLT -Scheme implementation. It implements the language as -described in the -.I Revised^4 Report on -.I the Algorithmic Language Scheme, -plus numerous extensions. -.I MzScheme -is the underlying implementation for -.I DrScheme -and -.I MrEd. -.SH OPTIONS - -Startup file and expression switches: -.TP -.BI \-e \ expr -Evaluates -.I expr -after -.I MzScheme -starts. -.TP -.BI \-f \ file -Loads -.I file -after -.I MzScheme -starts. -.TP -.BI \-d \ file -Load/cds -.I file -after -.I MzScheme -starts. -.TP -.B \-F -.br -Loads all remaining arguments after -.I MzScheme -starts. -.TP -.B \-D -.br -Load/cds all remaining arguments after -.I MzScheme -starts. -.TP -.B \-l \ file -Same as -e '(require-library "file")'. -.TP -.B \-r, --script -Script mode: use as last flag for scripts. -Same as -fmv-. -.TP -.B \-i, --script-cd -Like -r, but also sets the directory. -Same as -dmv-. -.TP -.B \-w, --awk -Same as -l awk.ss. -.PP - -Initialization switches: -.TP -.B \-x, --no-lib-path -Does not try to set current-library-collection-paths. -.TP -.B \-q, --no-init-file -Does not try to load "~/.mzschemerc". -.PP - -Language setting switches: -.TP -.B \-g, --case-sens -Identifiers and symbols are initially case-sensitive. -.TP -.B \-c, --esc-cont -Call/cc is replaced with call/ec. -.TP -.B \-k, --const-globs -Builtin globals are constant. -.TP -.B \-s, --set-undef -Set! works on undefined identifiers. -.TP -.B \-a, --no-auto-else -Fall-through cond or case is an error. -.TP -.B \-n, --no-key -Keywords are not enforced. -.TP -.B \-y, --hash-percent-syntax -Only #% syntactic forms are present. -.TP -.B \-p, --persistent -Catches AIX SIGDANGER (low page space) signal. (AIX only) -.PP - -Miscellaneous switches: -.TP -.B \-- -.br -No argument following this switch is used as a switch. -.TP -.B \-m, --mute-banner -Suppresses the startup banner. -.TP -.B \-v, --version -Suppresses the read-eval-print loop. -.TP -.B \-h, --help -Shows help for command-line arguments. -.TP -.BI \-R file, --restore \ file -Restores an image; must be the only switch. -.PP -Multiple single-letter switches can be collapsed, with arguments placed -after the collapsed switches; the first collapsed switch cannot be --. -E.g.: `-vfme file expr' is the same as `-v -f file -m -e expr'. -.PP -Extra arguments following the last switch are put into the Scheme global -variable `argv' as a vector of strings. The name used to start -.I MzScheme -is put into the global variable `program' as a string. -.PP -Extra arguments after a `--restore' file are returned as a vector of -strings to the continuation of the `write-image-to-file' call that created -the image. -.PP -Expressions/files are evaluated/loaded in order as provided. -.PP -The current-library-collections-path is automatically set before any -expressions/files are evaluated/loaded, unless the -x or --no-lib-path -switch is used. -.PP -.PP -For further information on -.I MzScheme, -please consult the on-line -documentation and other information available at -.PP -.ce 1 -http://www.cs.rice.edu/CS/PLT/packages/mzscheme/ -.SH FILES -The file "~/.mzschemerc" is loaded before any provided -expressions/files are evaluated/loaded, unless the -q or ---no-init-file switch is used. (Under Windows and MacOS, "mzscheme.rc" -is loaded from the start-up working directory.) -.PP -.I MzScheme -looks for the library collections directory using the -following search path: -.IP -If -.I MzScheme -was invoked with an absolute pathname, the directory -of the invoked executable is checked. If the executable -is a link, the directory of the referenced file is also -checked, recursively following links. -.IP -If -.I MzScheme -is invoked with a relative pathname, the -directories in the PATH environment variable containing -a file with the name of the program as invoked (usually -"mzscheme") are checked. Links are followed as in the -first case. -.IP -The path in the environment variable MZCOLS is tried. -.IP -The path in the environment variable PLTHOME is checked -for a "mzscheme" and then "collects" subdirectory. -.IP -The "/usr/local/lib/plt/mzscheme/collects" directory is -tried. -.PP -Please consult your local administrator to determine whether -the on-line documentation has been installed locally. -.SH BUGS -Submit bug reports via -.ce 1 -http://www.cs.rice.edu/CS/PLT/Gnats/ (encouraged) -or by e-mail to -.ce 1 -plt-bugs@cs.rice.edu (discouraged) -.SH AUTHOR -.I MzScheme -was implemented by Matthew Flatt (mflatt@cs.rice.edu). -It uses the conservative garbage collector implemented by Hans -Boehm and extended by John Ellis. MzScheme was originally based -on libscheme, written by Brent Benson. -.SH SEE ALSO -.BR drscheme(1), -.BR mred(1)