suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

...

Browse Source 
original commit: ebf561e60cef781e43010e1b64b1b294f5e357f9
This commit is contained in:
Robby Findler 1999-02-11 20:07:37 +00:00
parent 757b745111
commit c3c1312851
4 changed files with 7 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/framework/frame.ss
View File

@ -65,6 +65,7 @@
(make-object % parent))]) (make-object % parent))])
(sequence (sequence
(apply super-init args) (apply super-init args)
(send (group:get-the-frame-group) insert-frame this)
(make-object (get-menu-bar%) this)) (make-object (get-menu-bar%) this))
(private (private
[panel (make-root-area-container (get-area-container%) this)]) [panel (make-root-area-container (get-area-container%) this)])

6
collects/framework/gen-standard-menus.ss
View File

@ -5,7 +5,7 @@ string=? ; exec mred -mgaqvf $0
(require-library "pretty.ss") (require-library "pretty.ss")
(require-library "function.ss") (require-library "function.ss")
(load-relative "standard-menus-items.ss") (require-library "standard-menus-items.ss" "framework")
(define build-id (define build-id
(case-lambda (case-lambda
@ -111,7 +111,7 @@ string=? ; exec mred -mgaqvf $0
`(public [,(generic-name generic) `(public [,(generic-name generic)
,(generic-initializer generic)])) ,(generic-initializer generic)]))
(call-with-output-file "standard-menus.ss" (call-with-output-file (build-path (collection-path "framework") "standard-menus.ss")
(lambda (port) (lambda (port)
(pretty-print (pretty-print
`(define standard-menus<%> `(define standard-menus<%>
@ -131,7 +131,7 @@ string=? ; exec mred -mgaqvf $0
(pretty-print (pretty-print
`(define standard-menus-mixin `(define standard-menus-mixin
(mixin (basic<%>) (standard-menus<%>) args (mixin (basic<%>) (standard-menus<%>) args
(inherit get-menu-bar on-close show) (inherit get-menu-bar can-close? on-close show)
(sequence (apply super-init args)) (sequence (apply super-init args))
,@(append ,@(append
(map (lambda (x) (map (lambda (x)

2
collects/framework/standard-menus-items.ss
View File

@ -112,7 +112,7 @@
(make-between 'file-menu 'print 'close 'separator) (make-between 'file-menu 'print 'close 'separator)
(make-an-item 'file-menu 'close (make-an-item 'file-menu 'close
"Close this file" "Close this file"
'(lambda (item control) (when (on-close) (show #f)) #t) '(lambda (item control) (when (can-close?) (on-close) (show #f)) #t)
#\w "&Close" "") #\w "&Close" "")
(make-between 'file-menu 'close 'quit 'nothing) (make-between 'file-menu 'close 'quit 'nothing)
(make-an-item 'file-menu 'quit (make-an-item 'file-menu 'quit

3
collects/tests/framework/main.ss
View File

@ -150,11 +150,12 @@
(and (list? answer) (and (list? answer)
(= 2 (length answer)))) (= 2 (length answer))))
(error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer)) (error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer))
(if (eof-object? answer) (if (eof-object? answer)
(raise (make-eof-result)) (raise (make-eof-result))
(case (car answer) (case (car answer)
[(error) [(error)
(error 'send-sexp-to-mred (format "mred raised \"~a\"" (second answer)))] (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))]
[(cant-read) (error 'mred/cant-parse (second answer))] [(cant-read) (error 'mred/cant-parse (second answer))]
[(normal) [(normal)
(printf " ~a // ~a: received from mred:~n" section-name test-name) (printf " ~a // ~a: received from mred:~n" section-name test-name)