...
original commit: 4e371625890571db229d002321c36fd417441c7a
This commit is contained in:
Robby Findler
parent
3da1a2b285
commit
0d2ca27c93
|
|
@ -20,11 +20,11 @@
|
|||
|
||||
(define frame-width 600)
|
||||
(define frame-height 650)
|
||||
(let-values ([(w h) (get-display-size)])
|
||||
(when (< w frame-width)
|
||||
(set! frame-width (- (unbox w) 65)))
|
||||
(when (< w frame-height)
|
||||
(set! frame-height (- (unbox h) 65))))
|
||||
(let ([window-trimming-upper-bound-width 20]
|
||||
[window-trimming-upper-bound-height 50])
|
||||
(let-values ([(w h) (get-display-size)])
|
||||
(set! frame-width (min frame-width (- w window-trimming-upper-bound-width)))
|
||||
(set! frame-height (min frame-height (- h window-trimming-upper-bound-height)))))
|
||||
|
||||
(define basic<%> (interface (frame<%>)
|
||||
get-area-container%
|
||||
|
|
@ -141,9 +141,10 @@
|
|||
(finder:put-file))])
|
||||
(when file
|
||||
(send (get-editor) save-file file format))))])
|
||||
(inherit get-menu-item%)
|
||||
(override
|
||||
[file-menu:revert
|
||||
(lambda ()
|
||||
(lambda (item control)
|
||||
(let* ([b (box #f)]
|
||||
[edit (get-editor)]
|
||||
[filename (send edit get-filename b)])
|
||||
|
|
@ -170,29 +171,29 @@
|
|||
"Error Reverting"
|
||||
(format "could not read ~a" filename)))))))
|
||||
#t))]
|
||||
[file-menu:save (lambda ()
|
||||
[file-menu:save (lambda (item control)
|
||||
(send (get-editor) save-file)
|
||||
#t)]
|
||||
[file-menu:save-as (lambda () (save-as) #t)]
|
||||
[file-menu:save-as (lambda (item control) (save-as) #t)]
|
||||
[file-menu:between-print-and-close
|
||||
(lambda (file-menu)
|
||||
(make-object separator-menu-item% file-menu)
|
||||
(let ([split
|
||||
(lambda (panel%)
|
||||
(lambda ()
|
||||
(lambda (item control)
|
||||
(let ([win (get-edit-target-object)])
|
||||
(when (and win
|
||||
(is-a? win canvas<%>))
|
||||
(send (get-area-container) split win panel%)))))])
|
||||
(send file-menu append-item "Split Horizontally" (split horizontal-panel%))
|
||||
(send file-menu append-item "Split Vertically" (split vertical-panel%))
|
||||
(send file-menu append-item "Collapse"
|
||||
(lambda ()
|
||||
(make-object (get-menu-item%) "Split Horizontally" file-menu (split horizontal-panel%))
|
||||
(make-object (get-menu-item%) "Split Vertically" file-menu (split vertical-panel%))
|
||||
(make-object (get-menu-item%) "Collapse" file-menu
|
||||
(lambda (item control)
|
||||
(let ([canvas (get-edit-target-window)])
|
||||
(when canvas
|
||||
(send (get-area-container) collapse canvas))))))
|
||||
(make-object separator-menu-item% file-menu))]
|
||||
[file-menu:print (lambda ()
|
||||
[file-menu:print (lambda (item control)
|
||||
(send (get-editor) print
|
||||
#t
|
||||
#t
|
||||
|
|
@ -219,20 +220,20 @@
|
|||
|
||||
[edit-menu:between-find-and-preferences
|
||||
(lambda (edit-menu)
|
||||
(send edit-menu append-separator)
|
||||
(send edit-menu append-item "Insert Text Box"
|
||||
(edit-menu:do 'insert-text-box))
|
||||
(send edit-menu append-item "Insert Graphic Box"
|
||||
(edit-menu:do 'insert-graphic-box))
|
||||
(send edit-menu append-item "Insert Image..."
|
||||
(edit-menu:do 'insert-image))
|
||||
(send edit-menu append-item "Toggle Wrap Text"
|
||||
(lambda ()
|
||||
(let ([edit (get-edit-target-object)])
|
||||
(when (and edit
|
||||
(is-a? edit editor<%>))
|
||||
(send edit auto-wrap (not (send edit auto-wrap)))))))
|
||||
(send edit-menu append-separator))])
|
||||
(make-object separator-menu-item% edit-menu)
|
||||
(make-object (get-menu-item%) "Insert Text Box" edit-menu
|
||||
(edit-menu:do 'insert-text-box))
|
||||
(make-object (get-menu-item%) "Insert Graphic Box" edit-menu
|
||||
(edit-menu:do 'insert-graphic-box))
|
||||
(make-object (get-menu-item%) "Insert Image..." edit-menu
|
||||
(edit-menu:do 'insert-image))
|
||||
(make-object (get-menu-item%) "Toggle Wrap Text" edit-menu
|
||||
(lambda (item event)
|
||||
(let ([edit (get-edit-target-object)])
|
||||
(when (and edit
|
||||
(is-a? edit editor<%>))
|
||||
(send edit auto-wrap (not (send edit auto-wrap)))))))
|
||||
(make-object separator-menu-item% edit-menu))])
|
||||
|
||||
(override
|
||||
[help-menu:about (lambda (menu evt) (message-box (format "Welcome to ~a" (application:current-app-name))))]
|
||||
|
|
@ -245,13 +246,13 @@
|
|||
(lambda ()
|
||||
(unless c
|
||||
(set! c (make-object (get-canvas%) (get-area-container)))
|
||||
(send c set-media (get-editor)))
|
||||
(send c set-editor (get-editor)))
|
||||
c))]
|
||||
[get-editor (let ([e #f])
|
||||
(lambda ()
|
||||
(unless e
|
||||
(set! e (make-editor))
|
||||
(send (get-canvas) set-media e))
|
||||
(send (get-canvas) set-editor e))
|
||||
e))])
|
||||
(sequence
|
||||
(let ([icon (icon:get)])
|
||||
|
|
@ -259,7 +260,7 @@
|
|||
(set-icon icon)))
|
||||
(do-label)
|
||||
(let ([canvas (get-canvas)])
|
||||
(send (get-editor) load-file file-name)
|
||||
(send (get-editor) load-file file-name 'guess #f)
|
||||
(send canvas focus)))))
|
||||
|
||||
(define -text<%> (interface (-editor<%>)))
|
||||
|
|
@ -411,7 +412,7 @@
|
|||
(send find-edit set-searching-frame (get-top-level-window)))
|
||||
(super-on-focus x))])
|
||||
(sequence
|
||||
(super-init parent #f '(h-scroll))
|
||||
(super-init parent #f)
|
||||
(set-line-count 2))))
|
||||
|
||||
(define (init-find/replace-edits)
|
||||
|
|
@ -479,7 +480,7 @@
|
|||
(let ([close-canvas
|
||||
(lambda (canvas edit)
|
||||
(send edit remove-canvas canvas)
|
||||
(send canvas set-media #f))])
|
||||
(send canvas set-editor #f))])
|
||||
(close-canvas find-canvas find-edit)
|
||||
(close-canvas replace-canvas replace-edit))
|
||||
(when (eq? this (ivar find-edit searching-frame))
|
||||
|
|
@ -602,26 +603,27 @@
|
|||
-1)])
|
||||
(set-search-direction forward)
|
||||
(reset-search-anchor (get-text-to-search)))))]
|
||||
[close-button (make-object button% middle-right-panel
|
||||
(lambda args (hide-search)) "Hide")]
|
||||
[close-button (make-object button% "Hide"
|
||||
middle-right-panel
|
||||
(lambda args (hide-search)))]
|
||||
[hidden? #f])
|
||||
(sequence
|
||||
(let ([align
|
||||
(lambda (x y)
|
||||
(let ([m (max (send x get-width)
|
||||
(send y get-width))])
|
||||
(send x user-min-width m)
|
||||
(send y user-min-width m)))])
|
||||
(send x min-width m)
|
||||
(send y min-width m)))])
|
||||
(align search-button replace-button)
|
||||
(align replace&search-button replace-all-button))
|
||||
(for-each (lambda (x) (send x major-align-center))
|
||||
(for-each (lambda (x) (send x set-alignment 'center 'center))
|
||||
(list middle-left-panel middle-middle-panel))
|
||||
(for-each (lambda (x) (send x stretchable-in-y #f))
|
||||
(for-each (lambda (x) (send x stretchable-height #f))
|
||||
(list search-panel left-panel middle-left-panel middle-middle-panel middle-right-panel))
|
||||
(for-each (lambda (x) (send x stretchable-in-x #f))
|
||||
(for-each (lambda (x) (send x stretchable-width #f))
|
||||
(list middle-left-panel middle-middle-panel middle-right-panel))
|
||||
(send find-canvas set-media find-edit)
|
||||
(send replace-canvas set-media replace-edit)
|
||||
(send find-canvas set-editor find-edit)
|
||||
(send replace-canvas set-editor replace-edit)
|
||||
(send find-edit add-canvas find-canvas)
|
||||
(send replace-edit add-canvas replace-canvas)
|
||||
(hide-search #t))))
|
||||
|
|
@ -703,7 +705,8 @@
|
|||
rb)
|
||||
(send edit position-location 0 lb)
|
||||
(send canvas min-width
|
||||
(+ magic-space (- (unbox rb) (unbox lb)))))))))])
|
||||
(+ magic-space (- (inexact->exact (floor (unbox rb)))
|
||||
(inexact->exact (floor (unbox lb)))))))))))])
|
||||
|
||||
(rename [super-on-close on-close])
|
||||
(private
|
||||
|
|
@ -723,7 +726,7 @@
|
|||
[on-close
|
||||
(lambda ()
|
||||
(super-on-close)
|
||||
(send time-canvas set-media #f)
|
||||
(send time-canvas set-editor #f)
|
||||
(unregister-collecting-blit gc-canvas)
|
||||
(close-panel-callback))])
|
||||
|
||||
|
|
@ -763,31 +766,30 @@
|
|||
|
||||
(public
|
||||
[get-info-panel
|
||||
(let ([info-panel (make-object horizontal-panel%
|
||||
super-root)])
|
||||
(let ([info-panel (make-object horizontal-panel% super-root)])
|
||||
(lambda ()
|
||||
info-panel))])
|
||||
(private
|
||||
[lock-message (make-object message%
|
||||
(let ([b (icon:get-unlock-bitmap)])
|
||||
(if (send b ok?)
|
||||
(cons (icon:get-unlock-bdc) b)
|
||||
"Unlocked"))
|
||||
(get-info-panel)
|
||||
'(border))]
|
||||
[time-canvas (make-object editor-canvas% (get-info-panel))]
|
||||
(if (and #f (send b ok?))
|
||||
b
|
||||
"Unlocked"))
|
||||
(get-info-panel))]
|
||||
[time-canvas (make-object editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))]
|
||||
[_ (send time-canvas set-line-count 1)]
|
||||
[gc-canvas (make-object canvas% (get-info-panel) '(border))]
|
||||
[register-gc-blit
|
||||
(lambda ()
|
||||
(let ([bdc (icon:get-gc-on-dc)])
|
||||
(when (send bdc ok?)
|
||||
(let ([onb (icon:get-gc-on-bitmap)]
|
||||
[offb (icon:get-gc-off-bitmap)])
|
||||
(when (and (send onb ok?)
|
||||
(send offb ok?))
|
||||
(register-collecting-blit gc-canvas
|
||||
0 0
|
||||
(icon:get-gc-width)
|
||||
(icon:get-gc-height)
|
||||
(icon:get-gc-on-dc)
|
||||
(icon:get-gc-off-dc)))))])
|
||||
onb offb))))])
|
||||
|
||||
(sequence
|
||||
(unless (preferences:get 'framework:show-status-line)
|
||||
|
|
@ -796,37 +798,32 @@
|
|||
(list rest-panel))))
|
||||
(register-gc-blit)
|
||||
|
||||
(let ([bw (box 0)]
|
||||
[bh (box 0)]
|
||||
[gc-width (icon:get-gc-width)]
|
||||
(let ([gc-width (icon:get-gc-width)]
|
||||
[gc-height (icon:get-gc-height)])
|
||||
(send* gc-canvas
|
||||
(set-size 0 0 gc-width gc-height)
|
||||
(get-client-size bw bh))
|
||||
(send* gc-canvas
|
||||
(user-min-client-width gc-width)
|
||||
(user-min-client-height gc-height)
|
||||
(stretchable-in-x #f)
|
||||
(stretchable-in-y #f)))
|
||||
(min-client-width gc-width)
|
||||
(min-client-height gc-height)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)))
|
||||
(send* (get-info-panel)
|
||||
(major-align-right)
|
||||
(stretchable-in-y #f)
|
||||
(set-alignment 'right 'center)
|
||||
(stretchable-height #f)
|
||||
(spacing 3)
|
||||
(border 3))
|
||||
(send* time-canvas
|
||||
(set-media time-edit)
|
||||
(stretchable-in-x #f))
|
||||
(set-editor time-edit)
|
||||
(stretchable-width #f))
|
||||
(semaphore-wait time-semaphore)
|
||||
(determine-width wide-time time-canvas time-edit)
|
||||
(semaphore-post time-semaphore)
|
||||
(update-time))))
|
||||
|
||||
(define editor-info<%> (interface (info<%>)
|
||||
(define text-info<%> (interface (info<%>)
|
||||
overwrite-status-changed
|
||||
anchor-status-changed
|
||||
editor-position-changed))
|
||||
(define editor-info-mixin
|
||||
(mixin (info<%>) (editor-info<%>) args
|
||||
(define text-info-mixin
|
||||
(mixin (info<%>) (text-info<%>) args
|
||||
(inherit get-info-editor)
|
||||
(rename [super-on-close on-close])
|
||||
(private
|
||||
|
|
@ -942,16 +939,15 @@
|
|||
[anchor-message
|
||||
(make-object message%
|
||||
(let ([b (icon:get-anchor-bitmap)])
|
||||
(if (send b ok?)
|
||||
(cons (icon:get-anchor-bdc) b)
|
||||
(if (and #f (send b ok?))
|
||||
b
|
||||
"Anchor"))
|
||||
(get-info-panel) '(border))]
|
||||
(get-info-panel))]
|
||||
[overwrite-message
|
||||
(make-object message%
|
||||
"Overwrite"
|
||||
(get-info-panel)
|
||||
'(border))]
|
||||
[position-canvas (make-object editor-canvas% (get-info-panel))]
|
||||
(get-info-panel))]
|
||||
[position-canvas (make-object editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))]
|
||||
[_2 (send position-canvas set-line-count 1)]
|
||||
[position-edit (make-object text%)])
|
||||
|
||||
|
|
@ -972,8 +968,8 @@
|
|||
(send anchor-message show #f)
|
||||
(send overwrite-message show #f)
|
||||
(send* position-canvas
|
||||
(set-media position-edit)
|
||||
(stretchable-in-x #f))
|
||||
(set-editor position-edit)
|
||||
(stretchable-width #f))
|
||||
(determine-width "0000:000-0000:000"
|
||||
position-canvas
|
||||
position-edit)
|
||||
|
|
@ -1011,11 +1007,9 @@
|
|||
|
||||
(define -text% (text-mixin editor%))
|
||||
(define searchable% (searchable-mixin -text%))
|
||||
(define text-info% (info-mixin searchable%))
|
||||
(define text-info% (text-info-mixin (info-mixin searchable%)))
|
||||
(define text-info-file% (file-mixin text-info%))
|
||||
|
||||
(define -pasteboard% (pasteboard-mixin editor%))
|
||||
(define pasteboard-info% (info-mixin -pasteboard%))
|
||||
(define pasteboard-info-file% (file-mixin pasteboard-info%)))
|
||||
|
||||
|
||||
|
|
@ -158,8 +158,8 @@
|
|||
info<%>
|
||||
info-mixin
|
||||
|
||||
editor-info<%>
|
||||
editor-info-mixin
|
||||
text-info<%>
|
||||
text-info-mixin
|
||||
|
||||
file<%>
|
||||
file-mixin
|
||||
|
|
@ -167,6 +167,7 @@
|
|||
basic%
|
||||
standard-menus%
|
||||
editor%
|
||||
|
||||
text%
|
||||
searchable%
|
||||
text-info%
|
||||
|
|
@ -201,8 +202,8 @@
|
|||
get-anchor-bitmap
|
||||
get-anchor-bdc
|
||||
|
||||
get-gc-on-dc
|
||||
get-gc-off-dc
|
||||
get-gc-on-bitmap
|
||||
get-gc-off-bitmap
|
||||
get-gc-width
|
||||
get-gc-height))
|
||||
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ string=? ; exec mred -mgaqvf $0
|
|||
(make-object
|
||||
(get-menu-item%)
|
||||
(,join ,menu-before-string
|
||||
,(build-id name "-string")
|
||||
(,(build-id name "-string"))
|
||||
,menu-after-string)
|
||||
,(menu-name->id name-string)
|
||||
,name
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@
|
|||
(set! bitmap (make-object bitmap% p type))
|
||||
(set! bitmap-dc (make-object bitmap-dc%))
|
||||
(when (send bitmap ok?)
|
||||
(send bitmap-dc select-object bitmap)))])
|
||||
(send bitmap-dc set-bitmap bitmap)))])
|
||||
(unless (file-exists? p)
|
||||
(fprintf (current-error-port) "WARNING: couldn't find ~a~n" p))
|
||||
(values
|
||||
|
|
@ -60,14 +60,11 @@
|
|||
icon)))))
|
||||
|
||||
(define gc-on-bitmap #f)
|
||||
(define gc-on-bdc #f)
|
||||
(define (fetch)
|
||||
(unless gc-on-bdc
|
||||
(set! gc-on-bdc (make-object bitmap-dc%))
|
||||
(set! gc-on-bitmap ((load-icon "recycle.gif" 'gif)))
|
||||
(send gc-on-bdc select-object gc-on-bitmap)))
|
||||
(unless gc-on-bitmap
|
||||
(set! gc-on-bitmap ((load-icon "recycle.gif" 'gif)))))
|
||||
|
||||
(define (get-gc-on-dc) (fetch) gc-on-bdc)
|
||||
(define (get-gc-on-bitmap) (fetch) gc-on-bitmap)
|
||||
(define (get-gc-width) (fetch) (if (send gc-on-bitmap ok?)
|
||||
(send gc-on-bitmap get-width)
|
||||
10))
|
||||
|
|
@ -75,16 +72,15 @@
|
|||
(send gc-on-bitmap get-height)
|
||||
10))
|
||||
|
||||
(define get-gc-off-dc
|
||||
(let ([bdc #f])
|
||||
(define get-gc-off-bitmap
|
||||
(let ([bitmap #f])
|
||||
(lambda ()
|
||||
(if bdc
|
||||
bdc
|
||||
(if bitmap
|
||||
bitmap
|
||||
(begin
|
||||
(set! bdc (make-object bitmap-dc%))
|
||||
(send bdc select-object
|
||||
(make-object bitmap%
|
||||
(get-gc-width)
|
||||
(get-gc-height)))
|
||||
(send bdc clear)
|
||||
bdc))))))
|
||||
(let ([bdc (make-object bitmap-dc%)])
|
||||
(set! bitmap (make-object bitmap% (get-gc-width) (get-gc-height)))
|
||||
(send bdc set-bitmap bitmap)
|
||||
(send bdc clear)
|
||||
(send bdc set-bitmap #f)
|
||||
bitmap)))))))
|
||||
|
|
|
|||
|
|
@ -95,14 +95,14 @@
|
|||
(make-between 'file-menu 'revert 'save 'nothing)
|
||||
(make-an-item 'file-menu 'save
|
||||
"Save this file to disk"
|
||||
#f "s" "&Save" "")
|
||||
#f #\s "&Save" "")
|
||||
(make-an-item 'file-menu 'save-as
|
||||
"Prompt for a filename and save this file to disk"
|
||||
#f #f "Save" " &As...")
|
||||
(make-between 'file-menu 'save-as 'print 'separator)
|
||||
(make-an-item 'file-menu 'print
|
||||
"Print this file"
|
||||
#f "p" "&Print" "...")
|
||||
#f #\p "&Print" "...")
|
||||
(make-between 'file-menu 'print 'close 'separator)
|
||||
(make-an-item 'file-menu 'close
|
||||
"Close this file"
|
||||
|
|
|
|||
|
|
@ -1,21 +1,81 @@
|
|||
(test
|
||||
'basic-mixin-creation
|
||||
(lambda (x) x)
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(send (make-object (frame:basic-mixin frame%) "test") show #t))
|
||||
(wait-for-frame "test")
|
||||
(send-sexp-to-mred
|
||||
'(send (get-top-level-focus-window) show #f))
|
||||
#t))
|
||||
(let ([test-creation
|
||||
(lambda (name class-expression)
|
||||
(test
|
||||
name
|
||||
(lambda (x) x)
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
`(send (make-object ,class-expression "test") show #t))
|
||||
(wait-for-frame "test")
|
||||
(send-sexp-to-mred
|
||||
'(send (get-top-level-focus-window) show #f))
|
||||
#t)))])
|
||||
|
||||
(test
|
||||
'basic-mixin-creation
|
||||
(lambda (x) x)
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(send (make-object (frame:basic-mixin frame%) "test") show #t))
|
||||
(wait-for-frame "test")
|
||||
(send-sexp-to-mred
|
||||
'(send (get-top-level-focus-window) show #f))
|
||||
#t))
|
||||
(test-creation
|
||||
'basic%-creation
|
||||
'frame:basic%)
|
||||
(test-creation
|
||||
'basic-mixin-creation
|
||||
'(frame:basic-mixin frame%))
|
||||
|
||||
(test-creation
|
||||
'standard-menus%-creation
|
||||
'frame:standard-menus%)
|
||||
(test-creation
|
||||
'standard-menus-mixin
|
||||
'(frame:standard-menus-mixin frame:basic%))
|
||||
|
||||
(test-creation
|
||||
'text%-creation
|
||||
'frame:text%)
|
||||
(test-creation
|
||||
'text-mixin-creation
|
||||
'(frame:text-mixin frame:editor%))
|
||||
(test-creation
|
||||
'text-mixin-creation
|
||||
'(frame:text-mixin (frame:editor-mixin frame:standard-menus%)))
|
||||
|
||||
(test-creation
|
||||
'searchable%-creation
|
||||
'frame:searchable%)
|
||||
(test-creation
|
||||
'searchable-mixin
|
||||
'(frame:searchable-mixin frame:text%))
|
||||
|
||||
(test-creation
|
||||
'text-info%-creation
|
||||
'frame:text-info%)
|
||||
(test-creation
|
||||
'text-info-mixin-creation
|
||||
'(frame:info-mixin frame:searchable%))
|
||||
|
||||
(test-creation
|
||||
'text-info-file%-creation
|
||||
'frame:text-info-file%)
|
||||
(test-creation
|
||||
'text-info-file-mixin-creation
|
||||
'(frame:file-mixin frame:text-info%))
|
||||
|
||||
(test-creation
|
||||
'pasteboard%-creation
|
||||
'frame:pasteboard%)
|
||||
(test-creation
|
||||
'pasteboard-mixin-creation
|
||||
'(frame:pasteboard-mixin frame:editor%))
|
||||
(test-creation
|
||||
'pasteboard-mixin-creation
|
||||
'(frame:pasteboard-mixin (frame:editor-mixin frame:standard-menus%)))
|
||||
|
||||
(test-creation
|
||||
'pasteboard-info%-creation
|
||||
'frame:pasteboard-info%)
|
||||
(test-creation
|
||||
'pasteboard-info-mixin-creation
|
||||
'(frame:info-mixin frame:searchable%))
|
||||
|
||||
(test-creation
|
||||
'pasteboard-info-file%-creation
|
||||
'frame:pasteboard-info-file%)
|
||||
(test-creation
|
||||
'pasteboard-info-file-mixin-creation
|
||||
'(frame:file-mixin frame:pasteboard-info%)))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,8 @@
|
|||
(let ([pred (lambda (x) (void? x))])
|
||||
(let ([pred (lambda (x) (void? x))]
|
||||
[old-load-framework-automatically? (load-framework-automatically)])
|
||||
|
||||
(load-framework-automatically #f)
|
||||
|
||||
(test
|
||||
'macro.ss
|
||||
pred
|
||||
|
|
@ -17,13 +21,14 @@
|
|||
pred
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "tests.ss" "framework")
|
||||
(invoke-open-unit/sig
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [mred : mred-interfaces^ (mred-interfaces@)]
|
||||
[keys : framework:keys^ ((require-library "keys.ss" "framework"))]
|
||||
[test : framework:test^ ((require-library "testr.ss" "framework") mred keys)])
|
||||
(export (unit test))))
|
||||
(eval
|
||||
'(invoke-open-unit/sig
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [mred : mred-interfaces^ (mred-interfaces@)]
|
||||
[keys : framework:keys^ ((require-library "keys.ss" "framework"))]
|
||||
[test : framework:test^ ((require-library "testr.ss" "framework") mred keys)])
|
||||
(export (unit test)))))
|
||||
(global-defined-value 'test:run-one)
|
||||
(global-defined-value 'test:button-push)
|
||||
(void)))
|
||||
|
|
@ -48,25 +53,27 @@
|
|||
(lambda (x) x)
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "mred-interfaces.ss" "framework")
|
||||
(let ([orig-button% (global-defined-value 'button%)])
|
||||
(invoke-open-unit/sig mred-interfaces@)
|
||||
(let ([first-button% (global-defined-value 'button%)])
|
||||
(eval
|
||||
'(let ([orig-button% (global-defined-value 'button%)])
|
||||
(invoke-open-unit/sig mred-interfaces@)
|
||||
(let ([second-button% (global-defined-value 'button%)])
|
||||
(and (eq? second-button% first-button%)
|
||||
(not (eq? first-button% orig-button%))))))))
|
||||
(let ([first-button% (global-defined-value 'button%)])
|
||||
(invoke-open-unit/sig mred-interfaces@)
|
||||
(let ([second-button% (global-defined-value 'button%)])
|
||||
(and (eq? second-button% first-button%)
|
||||
(not (eq? first-button% orig-button%)))))))))
|
||||
(test
|
||||
'frameworkr.ss
|
||||
pred
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "frameworks.ss" "framework")
|
||||
(invoke-open-unit/sig
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [mred : mred-interfaces^ (mred-interfaces@)]
|
||||
[core : mzlib:core^ ((require-library "corer.ss"))]
|
||||
[framework : framework^ ((require-library "frameworkr.ss" "framework") core mred)])
|
||||
(export (open framework))))
|
||||
(eval
|
||||
'(invoke-open-unit/sig
|
||||
(compound-unit/sig
|
||||
(import)
|
||||
(link [mred : mred-interfaces^ (mred-interfaces@)]
|
||||
[core : mzlib:core^ ((require-library "corer.ss"))]
|
||||
[framework : framework^ ((require-library "frameworkr.ss" "framework") core mred)])
|
||||
(export (open framework)))))
|
||||
(global-defined-value 'test:run-one)
|
||||
(global-defined-value 'test:button-push)
|
||||
(global-defined-value 'frame:basic-mixin)
|
||||
|
|
@ -89,7 +96,7 @@
|
|||
(lambda (x) x)
|
||||
'(parameterize ([current-namespace (make-namespace 'mred)])
|
||||
(require-library "pretty.ss")
|
||||
(let* ([op (pretty-print-print-line)]
|
||||
(let* ([op ((global-defined-value 'pretty-print-print-line))]
|
||||
[np (lambda x (apply op x))])
|
||||
((global-defined-value 'pretty-print-print-line) np)
|
||||
(require-library "framework.ss" "framework")
|
||||
|
|
@ -104,4 +111,7 @@
|
|||
(require-library "framework.ss" "framework")
|
||||
(let* ([fw-button% (global-defined-value 'button%)])
|
||||
(and (eq? fw-button% test-button%)
|
||||
(not (eq? fw-button% orig-button%)))))))))
|
||||
(not (eq? fw-button% orig-button%))))))))
|
||||
|
||||
(load-framework-automatically old-load-framework-automatically?))
|
||||
|
||||
|
|
|
|||
|
|
@ -10,8 +10,9 @@
|
|||
|
||||
(define-struct eof-result ())
|
||||
|
||||
(define-values (shutdown-listener shutdown-mred mred-running? send-sexp-to-mred)
|
||||
(let ([listener
|
||||
(define-values (load-framework-automatically shutdown-listener shutdown-mred mred-running? send-sexp-to-mred)
|
||||
(let ([load-framework-automatically? #t]
|
||||
[listener
|
||||
(let loop ()
|
||||
(let ([port (load-relative "receive-sexps-port.ss")])
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
|
|
@ -39,13 +40,22 @@
|
|||
(let-values ([(in out) (tcp-accept listener)])
|
||||
(set! in-port in)
|
||||
(set! out-port out))
|
||||
(send-sexp-to-mred
|
||||
'(let ([s (make-semaphore 0)])
|
||||
(queue-callback (lambda ()
|
||||
(require-library "framework.ss" "framework")
|
||||
(semaphore-post s)))
|
||||
(semaphore-wait s))))])
|
||||
(when load-framework-automatically?
|
||||
(send-sexp-to-mred
|
||||
'(let ([s (make-semaphore 0)])
|
||||
(queue-callback (lambda ()
|
||||
(require-library "framework.ss" "framework")
|
||||
(test:run-interval 11)
|
||||
(semaphore-post s)))
|
||||
(semaphore-wait s)))))])
|
||||
(values
|
||||
(case-lambda
|
||||
[(new-load-framework-automatically?)
|
||||
(unless (eq? (not (not new-load-framework-automatically?))
|
||||
load-framework-automatically?)
|
||||
(set! load-framework-automatically? (not (not new-load-framework-automatically?)))
|
||||
(shutdown-mred))]
|
||||
[() load-framework-automatically?])
|
||||
(lambda ()
|
||||
(shutdown-mred)
|
||||
(tcp-close listener))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user