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

merged units branch

Browse Source 
svn: r5033
This commit is contained in:
Eli Barzilay 2006-12-05 20:31:14 +00:00
parent a9446922ab
commit 3459c3a58f
355 changed files with 11430 additions and 6949 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
collects/algol60/bd-tool.ss
View File

@ -1,22 +1,35 @@
(module bd-tool mzscheme
(require (lib "encode-decode.ss" "framework" "private"))
(decode 6d54db8e9b3010fd95291512aeea248d7a9156ea457dea733f60251b
4fc05b63b3b649367fdfb18140225e12983973e676864a62a32d541e
5f07ed112aa325149d47b50ba1189f0a36996b234248f6d930581d83
6ed6a6e89c1943950f758b1d168c7c0a4fda227827e5954b25ae3f09
8f11aa4a4115b0765605fe43894825d483f768239fcc8c25026109f8
9d8808c23b67630b8ac137b6188934998e237e4a2875c3653786df25
efc43fe44ebe601d09143bd19750c9411bc57b41e455ed8c21a77676
3414c234ce7c3d50a78554bb97be29ee32191da3c1ed64d4e9076a35
f936f3eed30c2868aab6c1c82f5ac596c167b6e96d51376d4cee5c41
bdc5cb555d82ec3222c7132c506ca8854138ec8e5ff2cfcaabbcb8f0
31784e7680c343f8e47f7f623379efdd592b84b4fa5fcb40f22b5449
237b1209cc7a784a0e8e6fbdf3313c43a5bbf474ef7e5e68fa5604fc
0467a7d583f1f8601c6760f1c2534e7ef2a2c312c2d0a32f0995d53b
bd5256dba2d7314f530e31e6355b34a9db04e1da86286cd459926b45
65702258fca3ad4c277013c106b1111d0922c92c53e039b2d515ac37
a8b430ae29a1f823fafe0abfb58f2d49e923fc4db27a57a4f1a79ad6
311d86201aea785a9d7af0cf453e70de28d5aa40c0dbd621b4ee92f3
41f53ab8340de9bc42bf12d68489e34184782581cd6085d4212ac616
fcc66cea56d80679ddd201d2f12fa5a4b9d16720cc733713d1a525d4
dd91dd0444ec7b7c8b94e969fc5be901363592a7c9d87f))
(module bd-tool mzscheme
(require (lib "encode-decode.ss" "framework" "private"))
(decode 05c1dd6edc460c06d057f9226301b2e86c5c23690103a9835c
e53a0f50602852d2ecce8f324379adb7ef3924b6a60aeaf6fb
48dd403909a6d24daf634c984a379d189493609a731ce33ac6
c4a09c04d351935fc79818949360f2d6f2758c0993f6316f56
6c6206a92da91a7a133983683cdf40d91c440a1a36b7aa23fc
abd10d341fbd5bf5306c6e550733332856057d0369740ba555
dfa08c7f18f40da4d12d683ca18c17666690da92aa41d21aa4
806255f4267206d178be814abc5b6872b3d921c94bdc2f2039
52d6b047df4073cbd9664fad863dfa8629e6b5e5bf9f27c624
7abdedebc4cc0c525b5235e4e49e2d4801c5aae84de40ca2f1
7c0365f33f40240554e2dd42939bcd0e495ee27e017d060dab
0a496b9082d53c3c92fac6f8c2a0cfa0615521690d52b09a87
cdd2ba39e30b338374069578b7d0e466b3439297b8079d2f90
c2cca06155a13386791873cc86e7ebcb573c5f5fbe32685855
e80cedf1112479893b24ad410a9ef1cca06155a133867990e4
25ee785a18529819b4f7f69ed4e0ade5ef0c525b52b570d4e4
f0d6f277502a7beb0eed63deacd8abb796ff63907decad3bb4
8f79b362afde5a0ef6b1b7eee33f06a92da91af62d0efb0bef
2d2983d496540dfb1687bde0bd256590da92aa814abc5ba8f6
08474d1e961e8b5d308eddfa8541738e63601cbbf50b28d5cd
7a72ace6410ef756c31eab65068d63b71e521d1eaba7e80662
06a92da91ae4706f1594eaf0583d4537c8e1deea0594937bb6
2005b49a0739dc5b0d7bac96199463118d2039dc5b85bd3b83
b239881454e2dd42939bcd0e4d31b7f582e967dcf7133f52f7
4de3f9277e3591f3d384a785994125de2d34b9d9ec2836465c
ed02496b9002655089770b4d6e363be4706ff582e967dcf713
3f52f74de3895f4de4fc3441413916d108121883865585626c
ed81a78519f4fb686e20695dad333368585528c6d61e787266
66d0f0331be8f7d1dc406ad9dc94999941c3aa8256f320877b
ab618fd53263de625d2dcc5bcadaad82722ca211941934b73a
20877babc8cccc0c7a6c56d19bc81944e3f906d23ee6cd8abd
aee69fedc3adeaab7db8550d474d1e961e8ba1c4bb856a8f70
d4e461e9b1d8054f0b33f3ff))

12
collects/algol60/tool.ss
View File

@ -1,7 +1,7 @@
(module tool mzscheme
(require (lib "tool.ss" "drscheme")
(lib "mred.ss" "mred")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "class.ss")
"parse.ss"
"simplify.ss"
@ -16,13 +16,13 @@
'base-importing-stx))
(define tool@
(unit/sig drscheme:tool-exports^
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define-values/invoke-unit/sig drscheme:tool-exports^
bd:tool@
bd
drscheme:tool^)
(define-values/invoke-unit bd:tool@
(import drscheme:tool^)
(export (prefix bd: drscheme:tool-exports^)))
(define (phase1) (bd:phase1))
(define (phase2)

60
collects/browser/browser-sig.ss
View File

@ -1,10 +1,62 @@
(module browser-sig mzscheme
(require (lib "unitsig.ss")
"private/sig.ss")
(require (lib "unit.ss"))
(provide browser^)
(provide relative-btree^
bullet-export^
hyper^
html-export^
html^)
(define-signature browser^
(define-signature html-export^
(html-img-ok
html-eval-ok
image-map-snip%))
(define-signature html^ extends html-export^
(html-convert
html-status-handler))
(define-signature bullet-export^
(bullet-size))
(define-signature hyper^
(open-url
(struct exn:file-saved-instead (pathname))
(struct exn:cancelled ())
hyper-text<%>
hyper-text-mixin
hyper-text%
hyper-canvas-mixin
hyper-canvas%
hyper-panel<%>
hyper-panel-mixin
hyper-panel%
hyper-frame<%>
hyper-frame-mixin
hyper-frame%
hyper-no-show-frame-mixin
hyper-no-show-frame%
editor->page
page->editor))
(define-signature relative-btree^
(make-btree
btree-get
btree-put!
btree-shift!
btree-for-each
btree-map))
#;(define-signature browser^
((open hyper^)
(open html-export^)
(open bullet-export^))))

39
collects/browser/browser-unit.ss
View File

@ -1,5 +1,5 @@
(module browser-unit mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "mred-sig.ss" "mred")
(lib "plt-installer-sig.ss" "setup")
(lib "tcp-sig.ss" "net")
@ -8,37 +8,16 @@
"browser-sig.ss"
"private/bullet.ss"
"private/html.ss"
"private/hyper.ss"
"private/sig.ss")
"private/hyper.ss")
(provide browser@)
(define pre-browser@
(compound-unit/sig
(import (plt-installer : setup:plt-installer^)
(mred : mred^)
(tcp : net:tcp^)
(url : net:url^))
(link [html : html^ (html@ mred url)]
[hyper : hyper^ (hyper@ html mred plt-installer url)]
[bullet-size : bullet-export^ ((unit/sig bullet-export^
(import)
(rename (html:bullet-size bullet-size))
(define html:bullet-size bullet-size)))])
(export (open hyper)
(open bullet-size)
(open (html : html-export^)))))
(define-unit-from-context bullet@ bullet-export^)
(define-compound-unit/infer browser@
(import setup:plt-installer^
mred^
url^)
(export hyper^ html-export^ bullet-export^)
(link html@ hyper@ bullet@)))
;; this extra layer of wrapper here is only to
;; ensure that the browser^ signature actually matches
;; the export of the pre-browser@ unit.
;; (it didn't before, so now we check.)
(define browser@
(compound-unit/sig
(import (plt-installer : setup:plt-installer^)
(mred : mred^)
(tcp : net:tcp^)
(url : net:url^))
(link [pre-browser : browser^ (pre-browser@ plt-installer mred tcp url)])
(export (open pre-browser)))))

10
collects/browser/browser.ss
View File

@ -1,5 +1,5 @@
(module browser mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "mred.ss" "mred")
(lib "mred-sig.ss" "mred")
(lib "plt-installer-sig.ss" "setup")
@ -10,10 +10,6 @@
"browser-sig.ss"
"browser-unit.ss")
(provide-signature-elements browser^)
(provide-signature-elements hyper^ html-export^ bullet-export^)
(define-values/invoke-unit/sig browser^ browser@ #f
setup:plt-installer^
mred^
net:tcp^
net:url^))
(define-values/invoke-unit/infer browser@))

21
collects/browser/htmltext.ss
View File

@ -1,25 +1,24 @@
(module htmltext mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "class.ss")
"private/sig.ss"
"browser-sig.ss"
"private/html.ss"
"private/bullet.ss"
(lib "url.ss" "net")
(lib "url-sig.ss" "net")
(lib "mred.ss" "mred")
(lib "mred-unit.ss" "mred")
(lib "mred-sig.ss" "mred")
(lib "external.ss" "browser"))
(define-values/invoke-unit/sig
html^
(compound-unit/sig
(import (MRED : mred^) (URL : net:url^))
(link [HTML : html^ (html@ MRED URL)])
(export (open HTML)))
#f
mred^
net:url^)
(define-unit-from-context url@ url^)
(define-values/invoke-unit
(compound-unit/infer (import) (export html^)
(link standard-mred@ url@ html@))
(import)
(export html^))
(define html-text<%>
(interface ((class->interface text%))

16
collects/browser/private/btree.ss
View File

@ -1,8 +1,5 @@
(module btree mzscheme
(require "sig.ss"
(lib "unitsig.ss"))
(provide btree@)
(module btree (lib "a-unit.ss")
(require "../browser-sig.ss")
;; Implements a red-black tree with relative indexing along right
;; splines. This allows the usual O(log(n)) operations, plus a
@ -10,10 +7,9 @@
;; (This is the same data structure as used for lines by MrEd's text%
;; class, but that one is implemented in C++.)
(define btree@
(unit/sig relative-btree^
(import)
(rename (create-btree make-btree))
(import)
(export (rename relative-btree^
(create-btree make-btree)))
(define-struct btree (root))
@ -222,4 +218,4 @@
(loop (node-right n)
here
(+ v (node-pos n))))))
(cdr start))))))
(cdr start))))

4
collects/browser/private/bullet.ss
View File

@ -1,7 +1,5 @@
(module bullet mzscheme
(require (lib "unitsig.ss")
(lib "mred.ss" "mred")
"sig.ss"
(require (lib "mred.ss" "mred")
(lib "class.ss"))
(provide bullet-snip%

22
collects/browser/private/html.ss
View File

@ -1,7 +1,5 @@
(module html mzscheme
(require (lib "unitsig.ss")
"sig.ss"
(module html (lib "a-unit.ss")
(require "../browser-sig.ss"
(lib "mred-sig.ss" "mred")
(lib "file.ss")
(lib "etc.ss")
@ -16,14 +14,12 @@
"bullet.ss"
"option-snip.ss"
"entity-names.ss")
(provide html@)
(define html@
(unit/sig html^
(import mred^
net:url^)
(import mred^ url^)
(export html^)
(init-depend mred^)
;; CACHE
(define NUM-CACHED 10)
(define cached (make-vector 10 'no-image))
@ -1262,4 +1258,4 @@
(f))
(send a-text add-tag "top" 0)
(update-image-maps image-map-snips image-maps)
(send a-text set-position 0)))))))))
(send a-text set-position 0)))))))

23
collects/browser/private/hyper.ss
View File

@ -28,10 +28,8 @@ A test case:
#f))
|#
(module hyper mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
"sig.ss"
(module hyper (lib "a-unit.ss")
(require (lib "class.ss")
"../browser-sig.ss"
(lib "file.ss")
(lib "list.ss")
@ -45,15 +43,14 @@ A test case:
(lib "string-constant.ss" "string-constants")
(lib "plt-installer-sig.ss" "setup"))
(provide hyper@)
(define hyper@
(unit/sig hyper^
(import html^
mred^
setup:plt-installer^
net:url^)
(import html^
mred^
setup:plt-installer^
url^)
(export hyper^)
(init-depend mred^)
(define-struct (exn:file-saved-instead exn) (pathname))
(define-struct (exn:cancelled exn) ())
(define-struct (exn:tcp-problem exn) ())
@ -1158,4 +1155,4 @@ A test case:
(eq? (car a) (car b)))
(define (open-url file)
(make-object hyper-frame% file (string-constant browser) #f 500 450)))))
(make-object hyper-frame% file (string-constant browser) #f 500 450)))

58
collects/browser/private/sig.ss
View File

@ -1,58 +0,0 @@
(module sig mzscheme
(require (lib "unitsig.ss"))
(provide relative-btree^
bullet-export^
hyper^
html-export^
html^)
(define-signature html-export^
(html-img-ok
html-eval-ok
image-map-snip%))
(define-signature html^
(html-convert
html-status-handler
(open html-export^)))
(define-signature bullet-export^
(bullet-size))
(define-signature hyper^
(open-url
(struct exn:file-saved-instead (pathname))
(struct exn:cancelled ())
hyper-text<%>
hyper-text-mixin
hyper-text%
hyper-canvas-mixin
hyper-canvas%
hyper-panel<%>
hyper-panel-mixin
hyper-panel%
hyper-frame<%>
hyper-frame-mixin
hyper-frame%
hyper-no-show-frame-mixin
hyper-no-show-frame%
editor->page
page->editor))
(define-signature relative-btree^
(make-btree
btree-get
btree-put!
btree-shift!
btree-for-each
btree-map)))

6
collects/browser/tool.ss
View File

@ -1,14 +1,14 @@
(module tool mzscheme
(require (lib "external.ss" "browser")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "tool.ss" "drscheme"))
(provide tool@)
;; to add a preference pannel to drscheme that sets the browser preference
(define tool@
(unit/sig drscheme:tool-exports^
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define phase1 void)
(define phase2 void)

98
collects/compiler/compiler-unit.ss
View File

@ -9,10 +9,10 @@
;; real MrSpidey) or loadr.ss (link in trivial MrSpidey stubs).
(module compiler-unit mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss")
(require "sig.ss")
(require (lib "file-sig.ss" "dynext")
"sig.ss"
(lib "file-sig.ss" "dynext")
(lib "link-sig.ss" "dynext")
(lib "compile-sig.ss" "dynext")
@ -20,9 +20,9 @@
(lib "collection-sig.ss" "make")
(lib "toplevel.ss" "syntax")
(lib "moddep.ss" "syntax"))
(lib "moddep.ss" "syntax")
(require (lib "list.ss")
(lib "list.ss")
(lib "file.ss")
(lib "compile.ss") ; gets compile-file
(lib "cm.ss")
@ -33,12 +33,12 @@
(define orig-namespace (current-namespace))
;; ;;;;;;;; ----- The main compiler unit ------ ;;;;;;;;;;
(define compiler@
(unit/sig compiler^
(define-unit compiler@
(import compiler:option^
dynext:compile^
dynext:link^
dynext:file^)
(export compiler^)
(define compile-notify-handler
(make-parameter void))
@ -60,8 +60,9 @@
(define (make-extension-compiler mode prefix)
(let ([u (c-dynamic-require `(lib "base.ss" "compiler" "private")
'base@)]
[init (unit/sig ()
[init (unit
(import compiler:inner^)
(export)
(eval-compile-prefix prefix)
(case mode
[(compile-extension) compile-extension]
@ -70,22 +71,21 @@
[(compile-extension-part) compile-extension-part]
[(compile-extension-part-to-c) compile-extension-part-to-c]
[(compile-c-extension-part) compile-c-extension-part]))])
(invoke-unit/sig
(compound-unit/sig
(invoke-unit
(compound-unit
(import (COMPILE : dynext:compile^)
(LINK : dynext:link^)
(DFILE : dynext:file^)
(OPTION : compiler:option^))
(link [COMPILER : compiler:inner^ (u COMPILE
LINK
DFILE
OPTION)]
[INIT : () (init COMPILER)])
(export))
dynext:compile^
dynext:link^
dynext:file^
compiler:option^)))
(export)
(link [((COMPILER : compiler:inner^))
u
COMPILE LINK DFILE OPTION]
[() init COMPILER]))
(import dynext:compile^
dynext:link^
dynext:file^
compiler:option^))))
(define (make-compiler mode)
(lambda (prefix)
@ -119,29 +119,29 @@
(define (link/glue-extension-parts link? compile? source-files destination-directory)
(let ([u (c-dynamic-require '(lib "ld-unit.ss" "compiler") 'ld@)]
[init (unit/sig ()
[init (unit
(import compiler:linker^)
(export)
(if link?
link-extension
(if compile?
glue-extension
glue-extension-source)))])
(let ([f (invoke-unit/sig
(compound-unit/sig
(let ([f (invoke-unit
(compound-unit
(import (COMPILE : dynext:compile^)
(LINK : dynext:link^)
(DFILE : dynext:file^)
(OPTION : compiler:option^))
(link [LINKER : compiler:linker^ (u COMPILE
LINK
DFILE
OPTION)]
[INIT : () (init LINKER)])
(export))
dynext:compile^
dynext:link^
dynext:file^
compiler:option^)])
(export)
(link [((LINKER : compiler:linker^))
u
COMPILE LINK DFILE OPTION]
[() init LINKER]))
(import dynext:compile^
dynext:link^
dynext:file^
compiler:option^))])
(f source-files destination-directory))))
(define (link-extension-parts source-files destination-directory)
@ -195,26 +195,26 @@
(define (compile-directory dir info zos?)
(let ([make (c-dynamic-require '(lib "make-unit.ss" "make") 'make@)]
[coll (c-dynamic-require '(lib "collection-unit.ss" "make") 'make:collection@)]
[init (unit/sig ()
(import make^ make:collection^)
[init (unit
(import make^ make:collection^)
(export)
(values make-collection make-notify-handler))])
(let-values ([(make-collection make-notify-handler)
(invoke-unit/sig
(compound-unit/sig
(invoke-unit
(compound-unit
(import (DFILE : dynext:file^)
(OPTION : compiler:option^)
(COMPILER : compiler^))
(link [MAKE : make^ (make)]
[COLL : make:collection^ (coll MAKE
DFILE
OPTION
COMPILER)]
[INIT : () (init MAKE COLL)])
(export))
dynext:file^
compiler:option^
compiler^)])
(let ([orig (current-directory)])
(export)
(link [((MAKE : make^)) make]
[((COLL : make:collection^))
coll
MAKE DFILE OPTION COMPILER]
[() init MAKE COLL]))
(import dynext:file^
compiler:option^
compiler^))])
(let ([orig (current-directory)])
(dynamic-wind
(lambda () (current-directory dir))
(lambda ()
@ -280,4 +280,4 @@
(compile-directory dir info #t))
)))
))

10
collects/compiler/compiler.ss
View File

@ -1,6 +1,6 @@
(module compiler mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require "sig.ss")
@ -16,13 +16,7 @@
(require "compiler-unit.ss")
(define-values/invoke-unit/sig compiler^
compiler@
#f
compiler:option^
dynext:compile^
dynext:link^
dynext:file^)
(define-values/invoke-unit/infer compiler@)
(provide-signature-elements compiler^))

2
collects/compiler/embed-sig.ss
View File

@ -1,6 +1,6 @@
(module embed-sig mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(provide compiler:embed^)
(define-signature compiler:embed^

8
collects/compiler/embed-unit.ss
View File

@ -1,6 +1,6 @@
(module embed-unit mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "file.ss")
(lib "list.ss")
(lib "etc.ss")
@ -19,9 +19,9 @@
(provide compiler:embed@)
(define compiler:embed@
(unit/sig compiler:embed^
(define-unit compiler:embed@
(import)
(export compiler:embed^)
(define (embedding-executable-is-directory? mred?)
#f)
@ -846,5 +846,5 @@
[(not p) #f]
[(list? p) (map mac-mred-collects-path-adjust p)]
[(relative-path? p) (build-path 'up 'up 'up p)]
[else p])))))
[else p]))))

6
collects/compiler/embed.ss
View File

@ -1,6 +1,6 @@
(module embed mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "contract.ss"))
(require "sig.ss")
@ -8,9 +8,7 @@
(require "embed-unit.ss"
"embed-sig.ss")
(define-values/invoke-unit/sig compiler:embed^
compiler:embed@
#f)
(define-values/invoke-unit/infer compiler:embed@)
(provide/contract [make-embedding-executable
(opt-> (path-string?

12
collects/compiler/ld-unit.ss
View File

@ -1,6 +1,6 @@
(module ld-unit mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss"))
(require "sig.ss")
@ -11,13 +11,13 @@
(provide ld@)
(define ld@
(unit/sig compiler:linker^
(define-unit ld@
(import dynext:compile^
dynext:link^
dynext:file^
(compiler:option : compiler:option^))
(rename (link-extension* link-extension))
(prefix compiler:option: compiler:option^))
(export (rename compiler:linker^
[link-extension* link-extension]))
;; Copied from library.ss; please fix me!
@ -308,4 +308,4 @@
(delete-file (build-path dest-dir _loader.o)))
(printf " [output to \"~a\"]~n" (build-path dest-dir _loader.so)))
(printf " [output to \"~a\"]~n" (build-path dest-dir _loader.o)))))))))
(printf " [output to \"~a\"]~n" (build-path dest-dir _loader.o))))))))

8
collects/compiler/option-unit.ss
View File

@ -1,14 +1,14 @@
(module option-unit mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require "sig.ss")
(provide compiler:option@)
(define compiler:option@
(unit/sig compiler:option^
(define-unit compiler:option@
(import)
(export compiler:option^)
(define propagate-constants (make-parameter #t))
(define assume-primitives (make-parameter #f))
@ -39,4 +39,4 @@
(define compile-for-embedded (make-parameter #f))
;; Maybe #f helps for register-poor architectures?
(define unpack-environments (make-parameter #f)))))
(define unpack-environments (make-parameter #f))))

6
collects/compiler/option.ss
View File

@ -1,12 +1,10 @@
(module option mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require "sig.ss")
(require "option-unit.ss")
(define-values/invoke-unit/sig
compiler:option^
compiler:option@)
(define-values/invoke-unit/infer compiler:option@)
(provide-signature-elements compiler:option^))

12
collects/compiler/private/analyze.ss
View File

@ -39,7 +39,7 @@
;;; ------------------------------------------------------------
(module analyze mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -49,12 +49,11 @@
(require "../sig.ss")
(provide analyze@)
(define analyze@
(unit/sig compiler:analyze^
(import (compiler:option : compiler:option^)
(define-unit analyze@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:prephase^
compiler:anorm^
@ -63,6 +62,7 @@
compiler:rep^
compiler:vm2c^
compiler:driver^)
(export compiler:analyze^)
(define-struct mod-glob (cname ;; a made-up name that encodes module + var
modname
@ -1385,4 +1385,4 @@
captured-vars
codes
max-arity
multi)))))))))
multi))))))))

13
collects/compiler/private/anorm.ss
View File

@ -30,7 +30,7 @@
;;; ------------------------------------------------------------
(module anorm mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -40,15 +40,14 @@
(require "../sig.ss")
(provide anorm@)
(define anorm@
(unit/sig
compiler:anorm^
(import (compiler:option : compiler:option^)
(define-unit anorm@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:driver^)
(export compiler:anorm^)
(define compiler:a-value?
(one-of zodiac:quote-form? zodiac:varref? zodiac:quote-syntax-form?))
@ -369,4 +368,4 @@
(k wcm))))))]
[else (error 'a-normalize "unsupported ~a" ast)]))])
a-normalize)))))
a-normalize))))

207
collects/compiler/private/base.ss
View File

@ -1,6 +1,6 @@
(module base mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require "../sig.ss")
(require "sig.ss")
@ -36,182 +36,29 @@
(provide base@)
(define base@
(compound-unit/sig
(import (COMPILE : dynext:compile^)
(LINK : dynext:link^)
(DFILE : dynext:file^)
(OPTIONS : compiler:option^))
(link
[ZODIAC : zodiac^ (zodiac@)]
[ZLAYER : compiler:zlayer^ (zlayer@
OPTIONS
ZODIAC
CSTRUCTS
DRIVER)]
[LIBRARY : compiler:library^ (library@
ZODIAC)]
[CSTRUCTS : compiler:cstructs^ (cstructs@
LIBRARY
ZODIAC
ZLAYER)]
[PREPHASE : compiler:prephase^ (prephase@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
DRIVER)]
[ANORM : compiler:anorm^ (anorm@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
DRIVER)]
[CONST : compiler:const^ (const@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ANALYZE
ZLAYER
VMSTRUCTS
TOP-LEVEL
DRIVER)]
[KNOWN : compiler:known^ (known@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
PREPHASE
ANORM
CONST
CLOSURE
REP
DRIVER)]
[ANALYZE : compiler:analyze^ (analyze@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
PREPHASE
ANORM
KNOWN
CONST
REP
VM2C
DRIVER)]
[LIFT : compiler:lift^ (lift@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
KNOWN
TOP-LEVEL
ANALYZE
CONST
CLOSURE
DRIVER)]
[CLOSURE : compiler:closure^ (closure@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
CONST
DRIVER)]
[VEHICLE : compiler:vehicle^ (vehicle@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
CONST
KNOWN
CLOSURE
DRIVER)]
[REP : compiler:rep^ (rep@
LIBRARY
CSTRUCTS
ANALYZE
ZODIAC
ZLAYER
CONST
VEHICLE
DRIVER)]
[VMSTRUCTS : compiler:vmstructs^ (vmscheme@
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
DRIVER)]
[VMPHASE : compiler:vmphase^ (vmphase@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
ANALYZE
CONST
VMSTRUCTS
REP
CLOSURE
VEHICLE
DRIVER)]
[VMOPT : compiler:vmopt^ (vmopt@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
VMSTRUCTS
KNOWN
REP
VMPHASE
DRIVER)]
[VM2C : compiler:vm2c^ (vm2c@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
ANALYZE
CONST
REP
CLOSURE
VEHICLE
VMSTRUCTS
DRIVER)]
[TOP-LEVEL : compiler:top-level^ (toplevel@
LIBRARY
CSTRUCTS)]
[DRIVER : compiler:driver^ (driver@
OPTIONS
LIBRARY
CSTRUCTS
ZODIAC
ZLAYER
PREPHASE
ANORM
KNOWN
ANALYZE
CONST
LIFT
CLOSURE
VEHICLE
REP
VMSTRUCTS
VMPHASE
VMOPT
VM2C
TOP-LEVEL
COMPILE
LINK
DFILE)])
(export (open (DRIVER : compiler:inner^))))))
(define-compound-unit/infer base@
(import (COMPILE : dynext:compile^)
(LINK : dynext:link^)
(DFILE : dynext:file^)
(OPTIONS : compiler:option^))
(export compiler:inner^)
(link
zodiac@
zlayer@
library@
cstructs@
prephase@
anorm@
const@
known@
analyze@
lift@
closure@
vehicle@
rep@
vmscheme@
vmphase@
vmopt@
vm2c@
toplevel@
driver@)))

13
collects/compiler/private/closure.ss
View File

@ -17,7 +17,7 @@
;;; ------------------------------------------------------------
(module closure mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -27,16 +27,15 @@
(require "../sig.ss")
(provide closure@)
(define closure@
(unit/sig
compiler:closure^
(import (compiler:option : compiler:option^)
(define-unit closure@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:const^
compiler:driver^)
(export compiler:closure^)
(define compiler:closure-list null)
(define compiler:add-closure!
@ -281,4 +280,4 @@
ast
(format
"closure-expression: form not supported: ~a" ast))]))])
(lambda (ast) (transform! ast)))))))
(lambda (ast) (transform! ast))))))

12
collects/compiler/private/const.ss
View File

@ -11,7 +11,7 @@
; that is prefixed onto the beginning of the program.
(module const mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -22,17 +22,17 @@
(require "../sig.ss")
(provide const@)
(define const@
(unit/sig compiler:const^
(import (compiler:option : compiler:option^)
(define-unit const@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:analyze^
compiler:zlayer^
compiler:vmstructs^
compiler:top-level^
compiler:driver^)
(export compiler:const^)
(define const:symbol-table (make-hash-table))
(define const:symbol-counter 0)
@ -432,5 +432,5 @@
(bytes? (zodiac:zread-object ast)))
(const:intern-string (zodiac:zread-object ast)))
(compiler:add-const! (compiler:re-quote ast)
varref:static)]))))))
varref:static)])))))

10
collects/compiler/private/cstructs.ss
View File

@ -5,7 +5,7 @@
;; Mostly structure definitions, mostly for annotations.
(module cstructs mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -15,11 +15,11 @@
(require "../sig.ss")
(provide cstructs@)
(define cstructs@
(unit/sig compiler:cstructs^
(define-unit cstructs@
(import compiler:library^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^)
(export compiler:cstructs^)
;;----------------------------------------------------------------------------
;; VARREF ATTRIBUTES
@ -226,4 +226,4 @@
(define-struct (compiler:error-msg compiler:message) ())
(define-struct (compiler:fatal-error-msg compiler:message) ())
(define-struct (compiler:internal-error-msg compiler:message) ())
(define-struct (compiler:warning-msg compiler:message) ()))))
(define-struct (compiler:warning-msg compiler:message) ())))

14
collects/compiler/private/driver.ss
View File

@ -60,7 +60,7 @@
;; the binding.
(module driver mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "file.ss")
(lib "port.ss")
@ -82,12 +82,11 @@
(provide driver@)
(define driver@
(unit/sig compiler:driver^
(import (compiler:option : compiler:option^)
(define-unit driver@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:prephase^
compiler:anorm^
@ -106,7 +105,8 @@
dynext:compile^
dynext:link^
dynext:file^)
(rename (compile-extension* compile-extension))
(export (rename compiler:driver^
[compile-extension* compile-extension]))
(define debug:file "dump.txt")
(define debug:port #f)
@ -1433,4 +1433,4 @@
(when (compiler:option:verbose)
(printf " finished [cpu ~a, real ~a].~n"
total-cpu-time
total-real-time))))))))
total-real-time)))))))

12
collects/compiler/private/known.ss
View File

@ -21,7 +21,7 @@
;;; ------------------------------------------------------------
(module known mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -31,12 +31,11 @@
(require "../sig.ss")
(provide known@)
(define known@
(unit/sig compiler:known^
(import (compiler:option : compiler:option^)
(define-unit known@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:prephase^
compiler:anorm^
@ -44,6 +43,7 @@
compiler:closure^
compiler:rep^
compiler:driver^)
(export compiler:known^)
;; helper functions to create a binding annotation
(define make-known-binding
@ -584,4 +584,4 @@
ast)))]))])
(lambda (ast)
(analyze! ast)))))))
(analyze! ast))))))

10
collects/compiler/private/library.ss
View File

@ -3,7 +3,7 @@
;; (c) 1997-8 PLT, Rice University
(module library mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -12,9 +12,9 @@
(require "sig.ss")
(provide library@)
(define library@
(unit/sig compiler:library^
(import (zodiac : zodiac^))
(define-unit library@
(import (prefix zodiac: zodiac^))
(export compiler:library^)
(define logical-inverse
(lambda (fun)
@ -332,4 +332,4 @@
" "))
(define (global-defined-value* v)
(and v (namespace-variable-value v))))))
(and v (namespace-variable-value v)))))

12
collects/compiler/private/lift.ss
View File

@ -21,7 +21,7 @@
;;; ------------------------------------------------------------
(module lift mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -31,12 +31,11 @@
(require "../sig.ss")
(provide lift@)
(define lift@
(unit/sig compiler:lift^
(import (compiler:option : compiler:option^)
(define-unit lift@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:known^
compiler:top-level^
@ -44,6 +43,7 @@
compiler:const^
compiler:closure^
compiler:driver^)
(export compiler:lift^)
(define lifting-allowed? #t)
(define mutual-lifting-allowed? #t)
@ -618,4 +618,4 @@
(set! globals empty-set)
(let ([ast (lift! ast code)])
(cons ast globals))))))))
(cons ast globals)))))))

13
collects/compiler/private/prephase.ss
View File

@ -40,7 +40,7 @@
;;; ------------------------------------------------------------
(module prephase mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require (lib "zodiac-sig.ss" "syntax"))
@ -48,15 +48,14 @@
(require "../sig.ss")
(provide prephase@)
(define prephase@
(unit/sig
compiler:prephase^
(import (compiler:option : compiler:option^)
(define-unit prephase@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:driver^)
(export compiler:prephase^)
(define-struct binding-properties (mutable? unit-i/e? ivar? anchor known-val))
@ -687,4 +686,4 @@
ast
(format "unsupported syntactic form ~a" ast))
ast]))])
prephase!)))))
prephase!))))

10
collects/compiler/private/rep.ss
View File

@ -15,7 +15,7 @@
;;; ------------------------------------------------------------
(module rep mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require (lib "zodiac-sig.ss" "syntax"))
@ -23,16 +23,16 @@
(require "../sig.ss")
(provide rep@)
(define rep@
(unit/sig compiler:rep^
(define-unit rep@
(import compiler:library^
compiler:cstructs^
compiler:analyze^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:const^
compiler:vehicle^
compiler:driver^)
(export compiler:rep^)
;;----------------------------------------------------------------------------
;; REPRESENTATION (TYPE) LANGUAGE
@ -230,4 +230,4 @@
(set-closure-code-rep! code struct)
(set-closure-code-alloc-rep! code alloc-struct)))))
)))
))

17
collects/compiler/private/sig.ss
View File

@ -1,6 +1,6 @@
(module sig mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require "../sig.ss")
(require (lib "zodiac-sig.ss" "syntax"))
@ -358,10 +358,8 @@
(vm-optimize!))
(provide compiler:driver^)
(define-signature compiler:driver^
((open compiler:inner^)
compiler:error
(define-signature compiler:driver^ extends compiler:inner^
(compiler:error
compiler:fatal-error
compiler:internal-error
compiler:warning
@ -420,11 +418,4 @@
vm->c:emit-case-prologue
vm->c:emit-case-epilogue
vm->c:emit-function-epilogue
vm->c-expression))
(provide compiler:basic-link^)
(define-signature compiler:basic-link^
((unit ZODIAC : zodiac^)
(unit ZLAYER : compiler:zlayer^)
(unit DRIVER : compiler:driver^)
(unit LIBRARY : compiler:library^))))
vm->c-expression)))

9
collects/compiler/private/toplevel.ss
View File

@ -3,16 +3,15 @@
;; (c) 1997-2001 PLT
(module toplevel mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require "sig.ss")
(provide toplevel@)
(define toplevel@
(unit/sig
compiler:top-level^
(define-unit toplevel@
(import compiler:library^
compiler:cstructs^)
(export compiler:top-level^)
;;-------------------------------------------------------------
;; This contains information about a top-level block, either at
@ -82,5 +81,5 @@
;; remove-code-captured-vars - parent handling is the same
;; as remove-code-free-vars
)))
))

14
collects/compiler/private/vehicle.ss
View File

@ -20,7 +20,7 @@
;;; ------------------------------------------------------------
(module vehicle mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require (lib "zodiac-sig.ss" "syntax"))
@ -28,18 +28,18 @@
(require "../sig.ss")
(provide vehicle@)
(define vehicle@
(unit/sig
compiler:vehicle^
(import (compiler:option : compiler:option^)
(define-unit vehicle@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:const^
compiler:known^
compiler:closure^
compiler:driver^)
(export compiler:vehicle^)
;; Used for union-find for lambda vehicles:
(define (get-vehicle-top code)
@ -241,5 +241,5 @@
(lambda (current-lambda ast) (relate! current-lambda ast))))
(define (vehicle:only-code-in-vehicle? code)
(= (vehicle-total-labels (get-vehicle (closure-code-vehicle code))) 1)))))
(= (vehicle-total-labels (get-vehicle (closure-code-vehicle code))) 1))))

13
collects/compiler/private/vm2c.ss
View File

@ -3,7 +3,7 @@
;; (c) 1997-2001 PLT
(module vm2c mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss"))
(require (lib "zodiac-sig.ss" "syntax")
@ -13,13 +13,11 @@
(require "../sig.ss")
(provide vm2c@)
(define vm2c@
(unit/sig
compiler:vm2c^
(import (compiler:option : compiler:option^)
(define-unit vm2c@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:analyze^
compiler:const^
@ -28,6 +26,7 @@
compiler:vehicle^
compiler:vmstructs^
compiler:driver^)
(export compiler:vm2c^)
(define local-vars-at-top? #f)
@ -1581,4 +1580,4 @@
ast
(format "vm:build-constant: not supported ~a" ast))]))]
[else (compiler:internal-error #f (format "vm2c: ~a not supported" ast))]))))))))
[else (compiler:internal-error #f (format "vm2c: ~a not supported" ast))])))))))

14
collects/compiler/private/vmopt.ss
View File

@ -8,7 +8,7 @@
(module vmopt mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -18,19 +18,19 @@
(require "../sig.ss")
(provide vmopt@)
(define vmopt@
(unit/sig
compiler:vmopt^
(import (compiler:option : compiler:option^)
(define-unit vmopt@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:vmstructs^
compiler:known^
compiler:rep^
compiler:vmphase^
compiler:driver^)
(export compiler:vmopt^)
(define satisfies-arity?
(lambda (arity L arglist)
@ -583,4 +583,4 @@
(set! new-locs empty-set)
(values
(process! ast)
new-locs))))))))
new-locs)))))))

12
collects/compiler/private/vmphase.ss
View File

@ -10,7 +10,7 @@
;; to macro uses (where the macros are defined in mzc.h).
(module vmphase mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -21,12 +21,11 @@
"../sig.ss")
(provide vmphase@)
(define vmphase@
(unit/sig compiler:vmphase^
(import (compiler:option : compiler:option^)
(define-unit vmphase@
(import (prefix compiler:option: compiler:option^)
compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:analyze^
compiler:const^
@ -35,6 +34,7 @@
compiler:closure^
compiler:vehicle^
compiler:driver^)
(export compiler:vmphase^)
;; vm:convert-bound-varref takes a bound-varref and turns it
;; into a vm:local-varref, taking into account its representation.
@ -1006,4 +1006,4 @@
(zodiac:zodiac-stx ast)
(convert ast
multi? (or leaf list) tail-pos tail? (not tail?)))
new-locals)))))))
new-locals))))))

10
collects/compiler/private/vmscheme.ss
View File

@ -6,7 +6,7 @@
(module vmscheme mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -16,13 +16,13 @@
(require "../sig.ss")
(provide vmscheme@)
(define vmscheme@
(unit/sig compiler:vmstructs^
(define-unit vmscheme@
(import compiler:library^
compiler:cstructs^
(zodiac : zodiac^)
(prefix zodiac: zodiac^)
compiler:zlayer^
compiler:driver^)
(export compiler:vmstructs^)
;; Block statements
(define-struct (vm:sequence zodiac:zodiac) (vals))
@ -131,7 +131,7 @@
void?
undefined?)])
(lambda (i)
(p? (syntax-e (zodiac:zodiac-stx i)))))))))
(p? (syntax-e (zodiac:zodiac-stx i))))))))
#|

13
collects/compiler/private/zlayer.ss
View File

@ -3,7 +3,7 @@
;; (c)1997-2001 PLT
(module zlayer mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "etc.ss"))
@ -13,12 +13,12 @@
(require "sig.ss")
(provide zlayer@)
(define zlayer@
(unit/sig compiler:zlayer^
(import (compiler:option : compiler:option^)
(zodiac : zodiac^)
(define-unit zlayer@
(import (prefix compiler:option: compiler:option^)
(prefix zodiac: zodiac^)
compiler:cstructs^
compiler:driver^)
(export compiler:zlayer^)
;;----------------------------------------------------------------------------
;; ANNOTATIONS
@ -245,5 +245,4 @@
`(module ... ,(zodiac->sexp/annotate (zodiac:module-form-body ast)))]
[else
(error 'zodiac->sexp/annotate "unsupported ~s" ast)]))))))
(error 'zodiac->sexp/annotate "unsupported ~s" ast)])))))

2
collects/compiler/sig.ss
View File

@ -1,7 +1,7 @@
(module sig mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(provide compiler:option^
compiler^

21
collects/drscheme/private/app.ss
View File

@ -1,7 +1,6 @@
(module app mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(module app (lib "a-unit.ss")
(require (lib "class.ss")
(lib "list.ss")
(lib "file.ss")
(lib "string-constant.ss" "string-constants")
@ -12,14 +11,12 @@
"drsig.ss"
"../acks.ss")
(provide app@)
(define app@
(unit/sig drscheme:app^
(import [drscheme:unit : drscheme:unit^]
[drscheme:frame : drscheme:frame^]
[drscheme:language-configuration : drscheme:language-configuration/internal^]
[help-desk : drscheme:help-desk^]
[drscheme:tools : drscheme:tools^])
(import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix help-desk: drscheme:help-desk^]
[prefix drscheme:tools: drscheme:tools^])
(export drscheme:app^)
(define about-frame%
(class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%))
@ -503,4 +500,4 @@
(cdr strs)
(cons lang good-langs)
(cons str good-strs))
(loop (cdr langs) (cdr strs) good-langs good-strs)))]))))))
(loop (cdr langs) (cdr strs) good-langs good-strs)))]))))

24
collects/drscheme/private/debug.ss
View File

@ -7,7 +7,7 @@ profile todo:
|#
(module debug mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "stacktrace.ss" "errortrace")
(lib "class.ss")
(lib "list.ss")
@ -23,14 +23,15 @@ profile todo:
(define orig (current-output-port))
(provide debug@)
(define debug@
(unit/sig drscheme:debug^
(import [drscheme:rep : drscheme:rep^]
[drscheme:frame : drscheme:frame^]
[drscheme:unit : drscheme:unit^]
[drscheme:language : drscheme:language^]
[drscheme:language-configuration : drscheme:language-configuration/internal^]
[drscheme:init : drscheme:init^])
(define-unit debug@
(import [prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:init: drscheme:init^])
(export drscheme:debug^)
(define (oprintf . args) (apply fprintf orig args))
@ -1931,6 +1932,5 @@ profile todo:
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
;;; ;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;; ; ;;; ;;;
(define-values/invoke-unit/sig stacktrace^ stacktrace@ #f stacktrace-imports^))))
(define-values/invoke-unit/infer stacktrace@)))

29
collects/drscheme/private/drsig.ss
View File

@ -1,6 +1,6 @@
(module drsig mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(provide drscheme:eval^
drscheme:debug^
@ -35,7 +35,7 @@
add-initial-modes
(struct mode (name surrogate repl-submit matches-language)
-setters
(- make-mode))))
-constructor)))
(define-signature drscheme:font^
(setup-preferences))
@ -97,10 +97,9 @@
language-dialog
fill-language-dialog))
(define-signature drscheme:language-configuration/internal^
(define-signature drscheme:language-configuration/internal^ extends drscheme:language-configuration^
(add-info-specified-languages
get-default-language-settings
(open drscheme:language-configuration^)
settings-preferences-symbol
add-built-in-languages
@ -269,14 +268,14 @@
phase2))
(define-signature drscheme:tool^
((unit drscheme:debug : drscheme:debug^)
(unit drscheme:unit : drscheme:unit^)
(unit drscheme:rep : drscheme:rep^)
(unit drscheme:frame : drscheme:frame^)
(unit drscheme:get/extend : drscheme:get/extend^)
(unit drscheme:language-configuration : drscheme:language-configuration^)
(unit drscheme:language : drscheme:language^)
(unit drscheme:help-desk : drscheme:help-desk^)
(unit drscheme:eval : drscheme:eval^)
(unit drscheme:teachpack : drscheme:teachpack^)
(unit drscheme:modes : drscheme:modes^))))
((open (prefix drscheme:debug: drscheme:debug^))
(open (prefix drscheme:unit: drscheme:unit^))
(open (prefix drscheme:rep: drscheme:rep^))
(open (prefix drscheme:frame: drscheme:frame^))
(open (prefix drscheme:get/extend: drscheme:get/extend^))
(open (prefix drscheme:language-configuration: drscheme:language-configuration^))
(open (prefix drscheme:language: drscheme:language^))
(open (prefix drscheme:help-desk: drscheme:help-desk^))
(open (prefix drscheme:eval: drscheme:eval^))
(open (prefix drscheme:teachpack: drscheme:teachpack^))
(open (prefix drscheme:modes: drscheme:modes^)))))

20
collects/drscheme/private/eval.ss
View File

@ -1,7 +1,7 @@
(module eval mzscheme
(require (lib "mred.ss" "mred")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "port.ss")
(lib "class.ss")
(lib "toplevel.ss" "syntax")
@ -15,14 +15,14 @@
(define (oprintf . args) (apply fprintf op args))
(provide eval@)
(define eval@
(unit/sig drscheme:eval^
(import [drscheme:language-configuration : drscheme:language-configuration/internal^]
[drscheme:rep : drscheme:rep^]
[drscheme:init : drscheme:init^]
[drscheme:language : drscheme:language^]
[drscheme:teachpack : drscheme:teachpack^])
(define-unit eval@
(import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:init: drscheme:init^]
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:teachpack: drscheme:teachpack^])
(export drscheme:eval^)
(define (traverse-program/multiple language-settings
init
kill-termination)
@ -226,4 +226,4 @@
(when (and (equal? #\# (car chars))
(equal? #\! (cadr chars)))
(read-line port))
(values port filename))]))))))
(values port filename))])))))

12
collects/drscheme/private/font.ss
View File

@ -1,5 +1,5 @@
(module font mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "class.ss")
"drsig.ss"
(lib "mred.ss" "mred")
@ -14,10 +14,10 @@
(provide font@)
(define font@
(unit/sig drscheme:font^
(import [drscheme:language-configuration : drscheme:language-configuration/internal^])
(define-unit font@
(import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^])
(export drscheme:font^)
(define (setup-preferences)
(preferences:add-panel
(list (string-constant font-prefs-panel-title)
@ -185,4 +185,4 @@
(send options-panel stretchable-height #f)
(send options-panel set-alignment 'center 'top)
(send text lock #t)
main)))))))
main))))))

23
collects/drscheme/private/frame.ss
View File

@ -1,8 +1,8 @@
(module frame mzscheme
(module frame (lib "a-unit.ss")
(require (lib "name-message.ss" "mrlib")
(lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "match.ss")
(lib "class.ss")
(lib "string.ss")
@ -17,16 +17,13 @@
(prefix mzlib:file: (lib "file.ss")) (lib "file.ss")
(prefix mzlib:list: (lib "list.ss")))
(provide frame@)
(define frame@
(unit/sig drscheme:frame^
(import [drscheme:unit : drscheme:unit^]
[drscheme:app : drscheme:app^]
[help : drscheme:help-desk^]
[drscheme:multi-file-search : drscheme:multi-file-search^]
[drscheme:init : drscheme:init^])
(rename [-mixin mixin])
(import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:app: drscheme:app^]
[prefix help: drscheme:help-desk^]
[prefix drscheme:multi-file-search: drscheme:multi-file-search^]
[prefix drscheme:init: drscheme:init^])
(export (rename drscheme:frame^
[-mixin mixin]))
(define basics<%> (interface (frame:standard-menus<%>)))
@ -560,4 +557,4 @@
#t)))
)))
)

21
collects/drscheme/private/get-extend.ss
View File

@ -1,21 +1,18 @@
(module get-extend mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(module get-extend (lib "a-unit.ss")
(require (lib "class.ss")
"drsig.ss"
(lib "mred.ss" "mred")
(lib "etc.ss"))
(provide get-extend@)
(define get-extend@
(unit/sig drscheme:get/extend^
(import [drscheme:unit : drscheme:unit^]
[drscheme:frame : drscheme:frame^]
[drscheme:rep : drscheme:rep^]
[drscheme:debug : drscheme:debug^])
(import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:debug: drscheme:debug^])
(export drscheme:get/extend^)
(define make-extender
(λ (get-base% name)
(let ([extensions (λ (x) x)]
@ -87,4 +84,4 @@
(drscheme:unit:get-definitions-text%))))
(define-values (extend-definitions-text get-definitions-text)
(make-extender get-base-definitions-text% 'definitions-text%)))))
(make-extender get-base-definitions-text% 'definitions-text%)))

22
collects/drscheme/private/help-desk.ss
View File

@ -1,7 +1,6 @@
(module help-desk mzscheme
(require (lib "unitsig.ss")
(lib "string-constant.ss" "string-constants")
(module help-desk (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
(lib "mred.ss" "mred")
(lib "external.ss" "browser")
(lib "help-desk.ss" "help")
@ -10,15 +9,14 @@
(lib "list.ss")
"drsig.ss")
(provide help-desk@)
(import [prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:teachpack: drscheme:teachpack^])
(export (rename drscheme:help-desk^
[-add-help-desk-font-prefs add-help-desk-font-prefs]))
(define help-desk@
(unit/sig drscheme:help-desk^
(import [drscheme:frame : drscheme:frame^]
[drscheme:language-configuration : drscheme:language-configuration/internal^]
[drscheme:teachpack : drscheme:teachpack^])
(rename [-add-help-desk-font-prefs add-help-desk-font-prefs])
(define (-add-help-desk-font-prefs b) (add-help-desk-font-prefs b))
;; : -> string
@ -190,4 +188,4 @@
;; open-url : string -> void
(define (open-url x) (send-url x))
(add-help-desk-mixin drscheme-help-desk-mixin))))
(add-help-desk-mixin drscheme-help-desk-mixin))

13
collects/drscheme/private/init.ss
View File

@ -1,16 +1,13 @@
(module init mzscheme
(module init (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
"drsig.ss"
(lib "list.ss")
(lib "mred.ss" "mred"))
(provide init@)
(define init@
(unit/sig drscheme:init^
(import)
(import)
(export drscheme:init^)
(define original-output-port (current-output-port))
(define original-error-port (current-error-port))
@ -53,4 +50,4 @@
[current-custodian system-custodian])
(queue-callback
(λ ()
(message-box title text #f '(stop ok)))))))))))))
(message-box title text #f '(stop ok)))))))))))

26
collects/drscheme/private/language-configuration.ss
View File

@ -1,6 +1,6 @@
(module language-configuration mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "hierlist.ss" "hierlist")
(lib "class.ss")
(lib "contract.ss")
@ -21,17 +21,17 @@
(provide language-configuration@)
(define language-configuration@
(unit/sig drscheme:language-configuration/internal^
(import [drscheme:unit : drscheme:unit^]
[drscheme:rep : drscheme:rep^]
[drscheme:teachpack : drscheme:teachpack^]
[drscheme:init : drscheme:init^]
[drscheme:language : drscheme:language^]
[drscheme:app : drscheme:app^]
[drscheme:tools : drscheme:tools^]
[drscheme:help-desk : drscheme:help-desk^])
(define-unit language-configuration@
(import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:teachpack: drscheme:teachpack^]
[prefix drscheme:init: drscheme:init^]
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:app: drscheme:app^]
[prefix drscheme:tools: drscheme:tools^]
[prefix drscheme:help-desk: drscheme:help-desk^])
(export drscheme:language-configuration/internal^)
;; settings-preferences-symbol : symbol
;; this pref used to depend on `version', but no longer does.
(define settings-preferences-symbol 'drscheme:language-settings)
@ -1869,4 +1869,4 @@
(define (find-parent-from-snip snip)
(let* ([admin (send snip get-admin)]
[ed (send admin get-editor)])
(find-parent-from-editor ed))))))
(find-parent-from-editor ed)))))

18
collects/drscheme/private/language.ss
View File

@ -3,13 +3,12 @@
;; user's io ports, to aid any debugging printouts.
;; (esp. useful when debugging the users's io)
(module language mzscheme
(module language (lib "a-unit.ss")
(require "drsig.ss"
(lib "string-constant.ss" "string-constants")
(lib "pconvert.ss")
(lib "pretty.ss")
(lib "etc.ss")
(lib "unitsig.ss")
(lib "struct.ss")
(lib "class.ss")
(lib "file.ss")
@ -22,15 +21,12 @@
(lib "distribute.ss" "compiler")
(lib "bundle-dist.ss" "compiler"))
(provide language@)
(import [prefix drscheme:debug: drscheme:debug^]
[prefix drscheme:teachpack: drscheme:teachpack^]
[prefix drscheme:tools: drscheme:tools^]
[prefix drscheme:help-desk: drscheme:help-desk^])
(export drscheme:language^)
(define language@
(unit/sig drscheme:language^
(import [drscheme:debug : drscheme:debug^]
[drscheme:teachpack : drscheme:teachpack^]
[drscheme:tools : drscheme:tools^]
[drscheme:help-desk : drscheme:help-desk^])
(define original-output-port (current-output-port))
(define (printf . args) (apply fprintf original-output-port args))
@ -1199,5 +1195,5 @@
'drscheme:language:extend-language-interface
'phase1)
(set! default-mixin (compose default-impl default-mixin))
(set! language-extensions (cons extension<%> language-extensions))))))
(set! language-extensions (cons extension<%> language-extensions))))

88
collects/drscheme/private/link.ss
View File

@ -8,7 +8,7 @@
"module-language.ss"
"teachpack.ss"
"tools.ss"
(lib "unitsig.ss")
(lib "unit.ss")
"language.ss"
"language-configuration.ss"
"drsig.ss"
@ -23,56 +23,36 @@
"help-desk.ss")
(provide drscheme@)
(define drscheme@
(compound-unit/sig
(import)
(link [init : drscheme:init^ (init@)]
[tools : drscheme:tools^
(tools@ frame unit rep get/extend language
(language-configuration : drscheme:language-configuration^)
help-desk init debug eval teachpack modes)]
[modes : drscheme:modes^ (modes@)]
[text : drscheme:text^ (text@)]
[teachpack : drscheme:teachpack^ (teachpack@)]
[eval : drscheme:eval^ (eval@ language-configuration rep init language teachpack)]
[frame : drscheme:frame^ (frame@ unit app help-desk multi-file-search init)]
[rep : drscheme:rep^
(rep@ init language-configuration language app
frame unit text help-desk teachpack debug eval)]
[language : drscheme:language^ (language@ debug teachpack tools help-desk)]
[module-overview : drscheme:module-overview^
(module-overview@ frame eval language-configuration language)]
[unit : drscheme:unit^
(unit@ help-desk app frame text rep language-configuration language
get/extend teachpack module-overview tools eval init
module-language modes)]
[debug : drscheme:debug^
(debug@ rep frame unit language language-configuration init)]
[multi-file-search : drscheme:multi-file-search^ (multi-file-search@ frame unit)]
[get/extend : drscheme:get/extend^ (get-extend@ unit frame rep debug)]
[language-configuration : drscheme:language-configuration/internal^
(language-configuration@ unit rep teachpack
init language app
tools help-desk)]
[font : drscheme:font^ (font@ language-configuration)]
[module-language : drscheme:module-language^
(module-language@ language-configuration language unit rep)]
[help-desk : drscheme:help-desk^ (help-desk@ frame language-configuration teachpack)]
[app : drscheme:app^ (app@ unit frame language-configuration help-desk tools)]
[main : () (main@
app unit get/extend language-configuration language teachpack
module-language tools debug frame font
modes
help-desk)])
(export
(unit debug drscheme:debug)
(unit unit drscheme:unit)
(unit rep drscheme:rep)
(unit frame drscheme:frame)
(unit get/extend drscheme:get/extend)
(unit language-configuration drscheme:language-configuration)
(unit language drscheme:language)
(unit help-desk drscheme:help-desk)
(unit eval drscheme:eval)
(unit teachpack drscheme:teachpack)
(unit modes drscheme:modes)))))
(define-compound-unit/infer drscheme-unit@
(import)
(export drscheme:debug^
drscheme:unit^
drscheme:rep^
drscheme:frame^
drscheme:get/extend^
drscheme:language-configuration^
drscheme:language^
drscheme:help-desk^
drscheme:eval^
drscheme:teachpack^
drscheme:modes^)
(link init@ tools@ modes@ text@ teachpack@ eval@ frame@ rep@ language@
module-overview@ unit@ debug@ multi-file-search@ get-extend@
language-configuration@ font@ module-language@ help-desk@ app@ main@))
(define-unit/new-import-export drscheme@
(import) (export drscheme:tool^)
(((prefix drscheme:debug: drscheme:debug^)
(prefix drscheme:unit: drscheme:unit^)
(prefix drscheme:rep: drscheme:rep^)
(prefix drscheme:frame: drscheme:frame^)
(prefix drscheme:get/extend: drscheme:get/extend^)
(prefix drscheme:language-configuration: drscheme:language-configuration^)
(prefix drscheme:language: drscheme:language^)
(prefix drscheme:help-desk: drscheme:help-desk^)
(prefix drscheme:eval: drscheme:eval^)
(prefix drscheme:teachpack: drscheme:teachpack^)
(prefix drscheme:modes: drscheme:modes^))
drscheme-unit@)))

39
collects/drscheme/private/main.ss
View File

@ -1,13 +1,11 @@
(module main mzscheme
(module main (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "cmdline.ss")
(lib "contract.ss")
"drsig.ss"
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "unitsig.ss")
(lib "class.ss")
(prefix pretty-print: (lib "pretty.ss"))
(prefix print-convert: (lib "pconvert.ss"))
@ -17,24 +15,21 @@
(lib "external.ss" "browser")
(lib "plt-installer.ss" "setup"))
(provide main@)
(define main@
(unit/sig ()
(import [drscheme:app : drscheme:app^]
[drscheme:unit : drscheme:unit^]
[drscheme:get/extend : drscheme:get/extend^]
[drscheme:language-configuration : drscheme:language-configuration/internal^]
[drscheme:language : drscheme:language^]
[drscheme:teachpack : drscheme:teachpack^]
[drscheme:module-language : drscheme:module-language^]
[drscheme:tools : drscheme:tools^]
[drscheme:debug : drscheme:debug^]
[drscheme:frame : drscheme:frame^]
[drscheme:font : drscheme:font^]
[drscheme:modes : drscheme:modes^]
[drscheme:help-desk : drscheme:help-desk^])
(import [prefix drscheme:app: drscheme:app^]
[prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:get/extend: drscheme:get/extend^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:teachpack: drscheme:teachpack^]
[prefix drscheme:module-language: drscheme:module-language^]
[prefix drscheme:tools: drscheme:tools^]
[prefix drscheme:debug: drscheme:debug^]
[prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:font: drscheme:font^]
[prefix drscheme:modes: drscheme:modes^]
[prefix drscheme:help-desk: drscheme:help-desk^])
(export)
(application-file-handler
(let ([default (application-file-handler)])
(λ (name)
@ -414,4 +409,4 @@
(λ () (drscheme:unit:open-drscheme-window f))))
no-dups)])
(when (null? (filter (λ (x) x) frames))
(make-basic))))))
(make-basic))))

16
collects/drscheme/private/modes.ss
View File

@ -1,17 +1,13 @@
(module modes mzscheme
(require (lib "unitsig.ss")
(lib "string-constant.ss" "string-constants")
(module modes (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
(lib "class.ss")
(lib "list.ss")
(lib "framework.ss" "framework")
"drsig.ss")
(provide modes@)
(define modes@
(unit/sig drscheme:modes^
(import)
(import)
(export drscheme:modes^)
(define-struct mode (name surrogate repl-submit matches-language))
(define modes (list))
@ -47,4 +43,4 @@
(λ (l)
(and l
(or (not-a-language-language? l)
(ormap (λ (x) (regexp-match #rx"Algol" x)) l)))))))))
(ormap (λ (x) (regexp-match #rx"Algol" x)) l)))))))

16
collects/drscheme/private/module-language.ss
View File

@ -1,7 +1,7 @@
(module module-language mzscheme
(provide module-language@)
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "embed.ss" "compiler")
@ -14,12 +14,12 @@
(define op (current-output-port))
(define (oprintf . args) (apply fprintf op args))
(define module-language@
(unit/sig drscheme:module-language^
(import [drscheme:language-configuration : drscheme:language-configuration/internal^]
[drscheme:language : drscheme:language^]
[drscheme:unit : drscheme:unit^]
[drscheme:rep : drscheme:rep^])
(define-unit module-language@
(import [prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:rep: drscheme:rep^])
(export drscheme:module-language^)
(define module-language<%>
(interface ()
@ -554,4 +554,4 @@
[else
(loop (+ pos 1))]))))
(super-instantiate ()))))))
(super-instantiate ())))))

38
collects/drscheme/private/module-overview.ss
View File

@ -10,7 +10,6 @@
(lib "string-constant.ss" "string-constants")
(lib "graph.ss" "mrlib")
"drsig.ss"
(lib "unitsig.ss")
(lib "unit.ss")
(lib "async-channel.ss"))
@ -24,12 +23,12 @@
(define adding-file (string-constant module-browser-adding-file))
(define unknown-module-name "? unknown module name")
(define module-overview@
(unit/sig drscheme:module-overview^
(import [drscheme:frame : drscheme:frame^]
[drscheme:eval : drscheme:eval^]
[drscheme:language-configuration : drscheme:language-configuration/internal^]
[drscheme:language : drscheme:language^])
(define-unit module-overview@
(import [prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:eval: drscheme:eval^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:language: drscheme:language^])
(export drscheme:module-overview^)
(define filename-constant (string-constant module-browser-filename-format))
(define font-size-gauge-label (string-constant module-browser-font-size-gauge-label))
@ -738,10 +737,9 @@
(define progress-channel (make-async-channel))
(define connection-channel (make-async-channel))
(define-values/invoke-unit (add-connections) process-program-unit
#f
progress-channel
connection-channel)
(define-values/invoke-unit process-program-unit
(import process-program-import^)
(export process-program-export^))
;; =user thread=
(define (iter sexp continue)
@ -864,7 +862,7 @@
(preferences:set 'drscheme:module-overview:window-width w)
(preferences:set 'drscheme:module-overview:window-height h)
(super on-size w h))
(super-instantiate ())))))
(super-instantiate ()))))
@ -886,11 +884,15 @@
; ; ; ;;;;
(define process-program-unit
(unit
(import progress-channel
connection-channel)
(export add-connections)
(define-signature process-program-import^
(progress-channel connection-channel))
(define-signature process-program-export^
(add-connections))
(define-unit process-program-unit
(import process-program-import^)
(export process-program-export^)
(define visited-hash-table (make-hash-table 'equal))
@ -1003,4 +1005,4 @@
(let-values ([(a b) (module-path-index-split dr)])
(and (pair? a)
(symbol? (car a))
(car a))))))))
(car a)))))))

16
collects/drscheme/private/multi-file-search.ss
View File

@ -1,8 +1,7 @@
(module multi-file-search mzscheme
(module multi-file-search (lib "a-unit.ss")
(require (lib "framework.ss" "framework")
(lib "class.ss")
(lib "unitsig.ss")
(lib "mred.ss" "mred")
(lib "file.ss")
(lib "thread.ss")
@ -10,13 +9,10 @@
(lib "string-constant.ss" "string-constants")
"drsig.ss")
(provide multi-file-search@)
(define multi-file-search@
(unit/sig drscheme:multi-file-search^
(import [drscheme:frame : drscheme:frame^]
[drscheme:unit : drscheme:unit^])
(import [prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:unit: drscheme:unit^])
(export drscheme:multi-file-search^)
;; multi-file-search : -> void
;; opens a dialog to configure the search and initiates the search
(define (multi-file-search)
@ -715,4 +711,4 @@
(car pos)
(- (cdr pos) (car pos))))))
(loop (+ line-number 1))]))))
'text))))))))
'text))))))

37
collects/drscheme/private/rep.ss
View File

@ -18,13 +18,13 @@ TODO
;; user's io ports, to aid any debugging printouts.
;; (esp. useful when debugging the users's io)
(module rep mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(require (lib "class.ss")
(lib "file.ss")
(lib "pretty.ss")
(lib "etc.ss")
(lib "list.ss")
(lib "port.ss")
(lib "unit.ss")
"drsig.ss"
(lib "string-constant.ss" "string-constants")
(lib "mred.ss" "mred")
@ -60,22 +60,21 @@ TODO
#f
(current-break-parameterization)))
(define rep@
(unit/sig drscheme:rep^
(import (drscheme:init : drscheme:init^)
(drscheme:language-configuration : drscheme:language-configuration/internal^)
(drscheme:language : drscheme:language^)
(drscheme:app : drscheme:app^)
(drscheme:frame : drscheme:frame^)
(drscheme:unit : drscheme:unit^)
(drscheme:text : drscheme:text^)
(drscheme:help-desk : drscheme:help-desk^)
(drscheme:teachpack : drscheme:teachpack^)
(drscheme:debug : drscheme:debug^)
[drscheme:eval : drscheme:eval^])
(rename [-text% text%]
[-text<%> text<%>])
(define-unit rep@
(import (prefix drscheme:init: drscheme:init^)
(prefix drscheme:language-configuration: drscheme:language-configuration/internal^)
(prefix drscheme:language: drscheme:language^)
(prefix drscheme:app: drscheme:app^)
(prefix drscheme:frame: drscheme:frame^)
(prefix drscheme:unit: drscheme:unit^)
(prefix drscheme:text: drscheme:text^)
(prefix drscheme:help-desk: drscheme:help-desk^)
(prefix drscheme:teachpack: drscheme:teachpack^)
(prefix drscheme:debug: drscheme:debug^)
[prefix drscheme:eval: drscheme:eval^])
(export (rename drscheme:rep^
[-text% text%]
[-text<%> text<%>]))
(define -text<%>
(interface ((class->interface text%)
@ -1787,4 +1786,4 @@ TODO
(text:nbsp->space-mixin
(mode:host-text-mixin
(text:foreground-color-mixin
text:clever-file-format%)))))))))))))))
text:clever-file-format%))))))))))))))

10
collects/drscheme/private/teachpack.ss
View File

@ -1,6 +1,6 @@
(module teachpack mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "list.ss")
(lib "file.ss")
(lib "etc.ss")
@ -14,9 +14,9 @@
(define o (current-output-port))
(define (oprintf . args) (apply fprintf o args))
(define teachpack@
(unit/sig drscheme:teachpack^
(import)
(define-unit teachpack@
(import)
(export drscheme:teachpack^)
;; type teachpack-cache = (make-teachpack-cache (listof cache-entry))
;; the timestamp indicates the last time this teachpack was loaded
@ -166,4 +166,4 @@
;; should check for error trace and use that here (somehow)
(if (exn? exn)
(format "~a" (exn-message exn))
(format "uncaught exception: ~s" exn))))))))
(format "uncaught exception: ~s" exn)))))))

14
collects/drscheme/private/text.ss
View File

@ -1,15 +1,11 @@
(module text mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(module text (lib "a-unit.ss")
(require (lib "class.ss")
"drsig.ss"
(lib "framework.ss" "framework"))
(provide text@)
(define text@
(unit/sig drscheme:text^
(import)
(import)
(export drscheme:text^)
(define text<%>
(interface (scheme:text<%>)
printing-on
@ -35,4 +31,4 @@
; (get-filename)
; "Untitled"))])
; (send dc draw-text str dx dy)))])
(super-new))))))
(super-new))))

5
collects/drscheme/private/time-keystrokes.ss
View File

@ -2,7 +2,7 @@
(require (lib "tool.ss" "drscheme")
(lib "list.ss")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "class.ss")
(lib "etc.ss")
(lib "mred.ss" "mred")
@ -16,8 +16,9 @@
(λ (i) (string-ref short-str (modulo i (string-length short-str))))))
(define tool@
(unit/sig drscheme:tool-exports^
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define (phase1) (void))
(define (phase2) (void))

40
collects/drscheme/private/tools.ss
View File

@ -1,7 +1,6 @@
(module tools mzscheme
(require (lib "unitsig.ss")
(lib "getinfo.ss" "setup")
(module tools (lib "a-unit.ss")
(require (lib "getinfo.ss" "setup")
(lib "mred.ss" "mred")
(lib "class.ss")
(lib "list.ss")
@ -11,22 +10,19 @@
(lib "framework.ss" "framework")
(lib "string-constant.ss" "string-constants"))
(provide tools@)
(define tools@
(unit/sig drscheme:tools^
(import [drscheme:frame : drscheme:frame^]
[drscheme:unit : drscheme:unit^]
[drscheme:rep : drscheme:rep^]
[drscheme:get/extend : drscheme:get/extend^]
[drscheme:language : drscheme:language^]
[drscheme:language-configuration : drscheme:language-configuration^]
[drscheme:help-desk : drscheme:help-desk^]
[drscheme:init : drscheme:init^]
[drscheme:debug : drscheme:debug^]
[drscheme:eval : drscheme:eval^]
[drscheme:teachpack : drscheme:teachpack^]
[drscheme:modes : drscheme:modes^])
(import [prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:get/extend: drscheme:get/extend^]
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:language-configuration: drscheme:language-configuration^]
[prefix drscheme:help-desk: drscheme:help-desk^]
[prefix drscheme:init: drscheme:init^]
[prefix drscheme:debug: drscheme:debug^]
[prefix drscheme:eval: drscheme:eval^]
[prefix drscheme:teachpack: drscheme:teachpack^]
[prefix drscheme:modes: drscheme:modes^])
(export drscheme:tools^)
;; successful-tool = (make-successful-tool module-spec
;; (union #f (instanceof bitmap%))
@ -211,9 +207,11 @@
;; invoke-tool : unit/sig string -> (values (-> void) (-> void))
;; invokes the tools and returns the two phase thunks.
(define (invoke-tool unit tool-name)
(define-unit-binding unit@ unit (import drscheme:tool^) (export drscheme:tool-exports^))
(wrap-tool-inputs
(let ()
(define-values/invoke-unit/sig drscheme:tool-exports^ unit #f drscheme:tool^)
(define-values/invoke-unit unit@
(import drscheme:tool^) (export drscheme:tool-exports^))
(values phase1 phase2))
tool-name))
@ -365,4 +363,4 @@
(error func "can only be called in phase: ~a"
(apply string-append
(map (lambda (x) (format "~e " x))
(filter (lambda (x) x) phases)))))))))
(filter (lambda (x) x) phases)))))))

43
collects/drscheme/private/unit.ss
View File

@ -13,7 +13,7 @@ module browser threading seems wrong.
(module unit mzscheme
(require (lib "contract.ss")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "class.ss")
(lib "file.ss")
(lib "etc.ss")
@ -42,26 +42,25 @@ module browser threading seems wrong.
(define show-planet-paths (string-constant module-browser-show-planet-paths/short))
(define refresh (string-constant module-browser-refresh))
(define unit@
(unit/sig drscheme:unit^
(import [help-desk : drscheme:help-desk^]
[drscheme:app : drscheme:app^]
[drscheme:frame : drscheme:frame^]
[drscheme:text : drscheme:text^]
[drscheme:rep : drscheme:rep^]
[drscheme:language-configuration : drscheme:language-configuration/internal^]
[drscheme:language : drscheme:language^]
[drscheme:get/extend : drscheme:get/extend^]
[drscheme:teachpack : drscheme:teachpack^]
[drscheme:module-overview : drscheme:module-overview^]
[drscheme:tools : drscheme:tools^]
[drscheme:eval : drscheme:eval^]
[drscheme:init : drscheme:init^]
[drscheme:module-language : drscheme:module-language^]
[drscheme:modes : drscheme:modes^])
(rename [-frame% frame%]
[-frame<%> frame<%>])
(define-unit unit@
(import [prefix help-desk: drscheme:help-desk^]
[prefix drscheme:app: drscheme:app^]
[prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:text: drscheme:text^]
[prefix drscheme:rep: drscheme:rep^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:get/extend: drscheme:get/extend^]
[prefix drscheme:teachpack: drscheme:teachpack^]
[prefix drscheme:module-overview: drscheme:module-overview^]
[prefix drscheme:tools: drscheme:tools^]
[prefix drscheme:eval: drscheme:eval^]
[prefix drscheme:init: drscheme:init^]
[prefix drscheme:module-language: drscheme:module-language^]
[prefix drscheme:modes: drscheme:modes^])
(export (rename drscheme:unit^
[-frame% frame%]
[-frame<%> frame<%>]))
(define-local-member-name
get-visible-defs
@ -3167,4 +3166,4 @@ module browser threading seems wrong.
[frame (new drs-frame% (filename filename))])
(send (send frame get-interactions-text) initialize-console)
(send frame show #t)
frame)))))
frame))))

8
collects/drscheme/syncheck.ss
View File

@ -17,7 +17,7 @@ If the namespace does not, they are colored the unbound color.
(module syncheck mzscheme
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "contract.ss")
(lib "tool.ss" "drscheme")
(lib "class.ss")
@ -67,9 +67,11 @@ If the namespace does not, they are colored the unbound color.
update-button-visibility/settings)
(define tool@
(unit/sig drscheme:tool-exports^
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define (phase1)
(drscheme:unit:add-to-program-editor-mixin clearing-text-mixin))

4
collects/drscheme/tool-lib.ss
View File

@ -11,11 +11,11 @@ all of the names in the tools library, for use defining keybindings
(require "private/link.ss"
"private/drsig.ss"
(lib "class.ss")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "framework.ss" "framework")
(lib "splash.ss" "framework"))
(shutdown-splash)
(define-values/invoke-unit/sig drscheme:tool^ drscheme@)
(define-values/invoke-unit/infer drscheme@)
(close-splash)
(provide-signature-elements drscheme:tool^))

2
collects/dynext/compile-sig.ss
View File

@ -1,6 +1,6 @@
(module compile-sig mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(provide dynext:compile^)

9
collects/dynext/compile-unit.ss
View File

@ -1,6 +1,6 @@
(module compile-unit mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "include.ss")
(lib "process.ss")
(lib "sendevent.ss")
@ -11,9 +11,9 @@
(provide dynext:compile@)
(define dynext:compile@
(unit/sig dynext:compile^
(define-unit dynext:compile@
(import)
(export dynext:compile^)
(define (get-unix-compile)
(or (find-executable-path "gcc" #f)
@ -289,4 +289,5 @@
(define compile-extension (make-compile-extension
current-extension-compiler-flags))
(define preprocess-extension (make-compile-extension
current-extension-compiler-flags)))))
current-extension-compiler-flags))))

5
collects/dynext/compile.ss
View File

@ -1,12 +1,11 @@
(module compile mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require "compile-sig.ss")
(require "compile-unit.ss")
(define-values/invoke-unit/sig dynext:compile^
dynext:compile@)
(define-values/invoke-unit/infer dynext:compile@)
(provide-signature-elements dynext:compile^))

BIN
collects/dynext/extension-project
View File

Binary file not shown.

2
collects/dynext/file-sig.ss
View File

@ -1,6 +1,6 @@
(module file-sig mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(provide dynext:file^)

8
collects/dynext/file-unit.ss
View File

@ -1,15 +1,15 @@
(module file-unit mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require (lib "include.ss"))
(require "file-sig.ss")
(provide dynext:file@)
(define dynext:file@
(unit/sig dynext:file^
(define-unit dynext:file@
(import)
(export dynext:file^)
(define (append-zo-suffix s)
(path-replace-suffix s #".zo"))
@ -82,5 +82,5 @@
[(macos macosx) #"[dD][yY][lL][iI][bB]"]
[(windows) #"[dD][lL][lL]"])
"MzScheme extension"
(extract-suffix append-extension-suffix))))))))
(extract-suffix append-extension-suffix)))))))

5
collects/dynext/file.ss
View File

@ -1,11 +1,10 @@
(module file mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require "file-sig.ss")
(require "file-unit.ss")
(define-values/invoke-unit/sig dynext:file^
dynext:file@)
(define-values/invoke-unit/infer dynext:file@)
(provide-signature-elements dynext:file^))

2
collects/dynext/link-sig.ss
View File

@ -1,6 +1,6 @@
(module link-sig mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(provide dynext:link^)

8
collects/dynext/link-unit.ss
View File

@ -1,6 +1,6 @@
(module link-unit mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "include.ss")
(lib "process.ss")
(lib "sendevent.ss")
@ -12,9 +12,9 @@
(provide dynext:link@)
(define dynext:link@
(unit/sig dynext:link^
(define-unit dynext:link@
(import)
(export dynext:link^)
(define (path-string->string s)
(if (string? s) s (path->string s)))
@ -425,4 +425,4 @@
(loop (add1 n))
f)))))
(include (build-path "private" "macinc.ss")))))
(include (build-path "private" "macinc.ss"))))

5
collects/dynext/link.ss
View File

@ -1,11 +1,10 @@
(module link mzscheme
(require (lib "unitsig.ss"))
(require (lib "unit.ss"))
(require "link-sig.ss")
(require "link-unit.ss")
(define-values/invoke-unit/sig dynext:link^
dynext:link@)
(define-values/invoke-unit/infer dynext:link@)
(provide-signature-elements dynext:link^))

BIN
collects/dynext/linking-project
View File

Binary file not shown.

6
collects/eopl/eopl-tool.ss
View File

@ -9,7 +9,7 @@ wraps the load of the module.)
|#
(module eopl-tool mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "class.ss")
(lib "tool.ss" "drscheme")
(lib "string-constant.ss" "string-constants"))
@ -17,9 +17,9 @@ wraps the load of the module.)
(provide tool@)
(define tool@
(unit/sig drscheme:tool-exports^
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define language-base%
(class* object% (drscheme:language:simple-module-based-language<%>)
(define/public (get-language-numbers)

5
collects/errortrace/errortrace-lib.ss
View File

@ -6,7 +6,7 @@
(require "stacktrace.ss"
"errortrace-key.ss"
(lib "list.ss")
(lib "unitsig.ss"))
(lib "unit.ss"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test coverage run-time support
@ -122,8 +122,7 @@
loc
expr)))))
(define-values/invoke-unit/sig
stacktrace^ stacktrace@ #f stacktrace-imports^)
(define-values/invoke-unit/infer stacktrace@)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Execute counts

12
collects/errortrace/stacktrace.ss
View File

@ -1,5 +1,5 @@
(module stacktrace mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "kerncase.ss" "syntax")
(lib "stx.ss" "syntax"))
@ -25,10 +25,10 @@
st-mark-source
st-mark-bindings))
(define stacktrace@
(unit/sig stacktrace^
(import stacktrace-imports^)
(define-unit stacktrace@
(import stacktrace-imports^)
(export stacktrace^)
(define (short-version v depth)
(cond
[(identifier? v) (syntax-e v)]
@ -549,4 +549,4 @@
(define annotate (make-annotate #f #f))
(define annotate-top (make-annotate #t #f))
(define (annotate-named name expr trans?)
((make-annotate #t name) expr trans?)))))
((make-annotate #t name) expr trans?))))

64
collects/framework/framework-sig.ss
View File

@ -1,63 +1,3 @@
(module framework-sig mzscheme
(require (lib "unitsig.ss")
"private/sig.ss")
(provide framework^ framework-class^)
(define-signature framework-class^
([unit application : framework:application-class^]
[unit version : framework:version-class^]
[unit color-model : framework:color-model-class^]
[unit exn : framework:exn-class^]
[unit exit : framework:exit-class^]
[unit preferences : framework:preferences-class^]
[unit number-snip : framework:number-snip-class^]
[unit autosave : framework:autosave-class^]
[unit handler : framework:handler-class^]
[unit keymap : framework:keymap-class^]
[unit path-utils : framework:path-utils-class^]
[unit icon : framework:icon-class^]
[unit editor : framework:editor-class^]
[unit pasteboard : framework:pasteboard-class^]
[unit text : framework:text-class^]
[unit finder : framework:finder-class^]
[unit group : framework:group-class^]
[unit canvas : framework:canvas-class^]
[unit panel : framework:panel-class^]
[unit menu : framework:menu-class^]
[unit frame : framework:frame-class^]
[unit color : framework:color-class^]
[unit color-prefs : framework:color-prefs-class^]
[unit scheme : framework:scheme-class^]
[unit comment-box : framework:comment-box-class^]
(unit mode : framework:mode-class^)
[unit main : framework:main-class^]))
(define-signature framework^
([unit application : framework:application^]
[unit version : framework:version^]
[unit color-model : framework:color-model^]
[unit exn : framework:exn^]
[unit exit : framework:exit^]
[unit preferences : framework:preferences^]
[unit number-snip : framework:number-snip^]
[unit autosave : framework:autosave^]
[unit handler : framework:handler^]
[unit keymap : framework:keymap^]
[unit path-utils : framework:path-utils^]
[unit icon : framework:icon^]
[unit editor : framework:editor^]
[unit pasteboard : framework:pasteboard^]
[unit text : framework:text^]
[unit finder : framework:finder^]
[unit group : framework:group^]
[unit canvas : framework:canvas^]
[unit panel : framework:panel^]
[unit menu : framework:menu^]
[unit frame : framework:frame^]
[unit color : framework:color^]
[unit color-prefs : framework:color-prefs^]
[unit scheme : framework:scheme^]
[unit comment-box : framework:comment-box^]
(unit mode : framework:mode^)
[unit main : framework:main^])))
(require "private/sig.ss")
(provide framework^))

147
collects/framework/framework-unit.ss
View File

@ -1,10 +1,8 @@
(module framework-unit mzscheme
(require (lib "unitsig.ss")
(lib "mred-sig.ss" "mred"))
(require (lib "unit.ss")
(lib "mred-sig.ss" "mred"))
(require "framework-sig.ss"
"private/sig.ss"
(require "private/sig.ss"
"private/number-snip.ss"
"private/comment-box.ss"
"private/application.ss"
@ -33,78 +31,69 @@
"private/main.ss"
"private/mode.ss")
(provide framework@)
(provide framework-separate@ framework@)
(define framework@
(compound-unit/sig
(import [mred : mred^])
(link [application : framework:application^ (application@)]
[version : framework:version^ (version@)]
[color-model : framework:color-model^ (color-model@ )]
[exn : framework:exn^ (exn@)]
[mode : framework:mode^ (mode@)]
[exit : framework:exit^ (exit@ mred preferences)]
[menu : framework:menu^ (menu@ mred preferences)]
[preferences : framework:preferences^ (preferences@ mred exn exit panel frame)]
[number-snip : framework:number-snip^ (number-snip@ mred preferences)]
[autosave : framework:autosave^ (autosave@ mred exit preferences frame
scheme editor text finder group)]
[path-utils : framework:path-utils^ (path-utils@)]
[icon : framework:icon^ (icon@ mred)]
[keymap : framework:keymap^
(keymap@ mred preferences finder handler frame editor)]
[editor : framework:editor^
(editor@ mred autosave finder path-utils keymap icon
preferences text pasteboard frame handler)]
[pasteboard : framework:pasteboard^ (pasteboard@ mred editor)]
[text : framework:text^
(text@ mred icon editor preferences keymap
color-model frame scheme number-snip)]
[color : framework:color^ (color@ preferences icon mode text color-prefs scheme)]
[color-prefs : framework:color-prefs^ (color-prefs@ preferences editor panel canvas)]
[comment-box : framework:comment-box^
(comment-box@ text scheme keymap)]
[finder : framework:finder^ (finder@ mred preferences keymap)]
[group : framework:group^
(group@ mred application frame preferences text canvas menu)]
[canvas : framework:canvas^ (canvas@ mred preferences frame text)]
[panel : framework:panel^ (panel@ icon mred)]
[frame : framework:frame^
(frame@ mred group preferences icon handler application panel
finder keymap text pasteboard editor canvas menu scheme exit
comment-box)]
[handler : framework:handler^
(handler@ mred finder group text preferences frame)]
[scheme : framework:scheme^
(scheme@ mred preferences
icon keymap text editor frame comment-box mode color color-prefs)]
[main : framework:main^ (main@ mred preferences exit group handler editor color-prefs scheme)])
(export (unit number-snip)
(unit menu)
(unit application)
(unit version)
(unit color-model)
(unit exn)
(unit exit)
(unit preferences)
(unit autosave)
(unit handler)
(unit keymap)
(unit path-utils)
(unit icon)
(unit editor)
(unit pasteboard)
(unit text)
(unit color)
(unit color-prefs)
(unit comment-box)
(unit finder)
(unit group)
(unit canvas)
(unit panel)
(unit frame)
(unit scheme)
(unit mode)
(unit main)))))
(define-compound-unit/infer framework-separate@
(import mred^)
(export framework:application^
framework:version^
framework:color-model^
framework:exn^
framework:mode^
framework:exit^
framework:menu^
framework:preferences^
framework:number-snip^
framework:autosave^
framework:path-utils^
framework:icon^
framework:keymap^
framework:editor^
framework:pasteboard^
framework:text^
framework:color^
framework:color-prefs^
framework:comment-box^
framework:finder^
framework:group^
framework:canvas^
framework:panel^
framework:frame^
framework:handler^
framework:scheme^
framework:main^)
(link
application@ version@ color-model@ exn@ mode@ exit@ menu@
preferences@ number-snip@ autosave@ path-utils@ icon@ keymap@
editor@ pasteboard@ text@ color@ color-prefs@ comment-box@
finder@ group@ canvas@ panel@ frame@ handler@ scheme@ main@))
(define-unit/new-import-export framework@ (import mred^) (export framework^)
(((prefix application: framework:application^)
(prefix version: framework:version^)
(prefix color-model: framework:color-model^)
(prefix exn: framework:exn^)
(prefix mode: framework:mode^)
(prefix exit: framework:exit^)
(prefix menu: framework:menu^)
(prefix preferences: framework:preferences^)
(prefix number-snip: framework:number-snip^)
(prefix autosave: framework:autosave^)
(prefix path-utils: framework:path-utils^)
(prefix icon: framework:icon^)
(prefix keymap: framework:keymap^)
(prefix editor: framework:editor^)
(prefix pasteboard: framework:pasteboard^)
(prefix text: framework:text^)
(prefix color: framework:color^)
(prefix color-prefs: framework:color-prefs^)
(prefix comment-box: framework:comment-box^)
(prefix finder: framework:finder^)
(prefix group: framework:group^)
(prefix canvas: framework:canvas^)
(prefix panel: framework:panel^)
(prefix frame: framework:frame^)
(prefix handler: framework:handler^)
(prefix scheme: framework:scheme^)
(prefix main: framework:main^))
framework-separate@ mred^)))

50
collects/framework/framework.ss
View File

@ -1,8 +1,9 @@
(module framework mzscheme
(require (lib "unitsig.ss")
(lib "mred.ss" "mred")
(require (lib "unit.ss")
(lib "mred-unit.ss" "mred")
(lib "mred-sig.ss" "mred")
(lib "mred.ss" "mred")
(lib "class.ss")
"test.ss"
@ -10,11 +11,38 @@
"decorated-editor-snip.ss"
"framework-unit.ss"
"framework-sig.ss"
"private/sig.ss"
(lib "contract.ss"))
(provide-signature-elements framework-class^)
(provide-signature-elements
(prefix application: framework:application-class^)
(prefix version: framework:version-class^)
(prefix color-model: framework:color-model-class^)
(prefix exn: framework:exn-class^)
(prefix mode: framework:mode-class^)
(prefix exit: framework:exit-class^)
(prefix menu: framework:menu-class^)
(prefix preferences: framework:preferences-class^)
(prefix number-snip: framework:number-snip-class^)
(prefix autosave: framework:autosave-class^)
(prefix path-utils: framework:path-utils-class^)
(prefix icon: framework:icon-class^)
(prefix keymap: framework:keymap-class^)
(prefix editor: framework:editor-class^)
(prefix pasteboard: framework:pasteboard-class^)
(prefix text: framework:text-class^)
(prefix color: framework:color-class^)
(prefix color-prefs: framework:color-prefs-class^)
(prefix comment-box: framework:comment-box-class^)
(prefix finder: framework:finder-class^)
(prefix group: framework:group-class^)
(prefix canvas: framework:canvas-class^)
(prefix panel: framework:panel-class^)
(prefix frame: framework:frame-class^)
(prefix handler: framework:handler-class^)
(prefix scheme: framework:scheme-class^)
(prefix main: framework:main-class^))
(provide (all-from "test.ss")
(all-from "gui-utils.ss")
@ -27,13 +55,15 @@
(syntax-case stx ()
[(_ (name contract docs ...) ...)
(syntax (provide/contract (name contract) ...))]))
(define-values/invoke-unit/sig
framework^
framework@
#f
mred^)
(define-compound-unit/infer framework+mred@
(import)
(export framework^)
(link standard-mred@ framework@))
(define-values/invoke-unit/infer framework+mred@)
(provide/contract/docs
(number-snip:make-repeating-decimal-snip

32
collects/framework/private/application.ss
View File

@ -1,18 +1,14 @@
(module application mzscheme
(require (lib "unitsig.ss")
"sig.ss"
(lib "mred-sig.ss" "mred"))
(provide application@)
(define application@
(unit/sig framework:application^
(import)
(define current-app-name (make-parameter
"MrEd"
(λ (x)
(unless (string? x)
(error 'current-app-name
"the app name must be a string"))
x))))))
(module application (lib "a-unit.ss")
(require "sig.ss")
(import)
(export framework:application^)
(define current-app-name (make-parameter
"MrEd"
(λ (x)
(unless (string? x)
(error 'current-app-name
"the app name must be a string"))
x))))

36
collects/framework/private/autosave.ss
View File

@ -1,29 +1,27 @@
(module autosave mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(module autosave (lib "a-unit.ss")
(require (lib "class.ss")
(lib "file.ss")
"sig.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
(lib "mred.ss" "mred") ;; remove this!
(lib "list.ss")
(lib "string-constant.ss" "string-constants"))
(provide autosave@)
(lib "string-constant.ss" "string-constants")
(lib "unit.ss"))
(import mred^
[prefix exit: framework:exit^]
[prefix preferences: framework:preferences^]
[prefix frame: framework:frame^]
[prefix scheme: framework:scheme^]
[prefix editor: framework:editor^]
[prefix text: framework:text^]
[prefix finder: framework:finder^]
[prefix group: framework:group^])
(export framework:autosave^)
(define autosave@
(unit/sig framework:autosave^
(import mred^
[exit : framework:exit^]
[preferences : framework:preferences^]
[frame : framework:frame^]
[scheme : framework:scheme^]
[editor : framework:editor^]
[text : framework:text^]
[finder : framework:finder^]
[group : framework:group^])
(define autosavable<%>
(interface ()
do-autosave))
@ -316,4 +314,4 @@
(delete-file autosave-name)
(when tmp-name
(delete-file tmp-name))
orig-name))))))))
orig-name))))))

22
collects/framework/private/canvas.ss
View File

@ -1,19 +1,15 @@
(module canvas mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(module canvas (lib "a-unit.ss")
(require (lib "class.ss")
"sig.ss"
(lib "mred-sig.ss" "mred"))
(provide canvas@)
(import mred^
[prefix preferences: framework:preferences^]
[prefix frame: framework:frame^]
[prefix text: framework:text^])
(define canvas@
(unit/sig framework:canvas^
(import mred^
[preferences : framework:preferences^]
[frame : framework:frame^]
[text : framework:text^])
(rename [-color% color%])
(export (rename framework:canvas^
(-color% color%)))
(define basic<%> (interface ((class->interface editor-canvas%))))
(define basic-mixin
@ -182,4 +178,4 @@
(define -color% (color-mixin basic%))
(define info% (info-mixin basic%))
(define delegate% (delegate-mixin basic%))
(define wide-snip% (wide-snip-mixin basic%)))))
(define wide-snip% (wide-snip-mixin basic%)))

15
collects/framework/private/color-model.ss
View File

@ -1,16 +1,11 @@
(module color-model mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(module color-model (lib "a-unit.ss")
(require (lib "class.ss")
"sig.ss"
(lib "mred-sig.ss" "mred")
(lib "list.ss"))
(provide color-model@)
(define color-model@
(unit/sig framework:color-model^
(import)
(import)
(export framework:color-model^)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; matrix ops ;;;
@ -270,4 +265,4 @@
;; (print-struct #t)
;; (xyz->luv (make-xyz 95.0 100.0 141.0))
;; (xyz->luv (make-xyz 60.0 80.0 20.0))
)))
)

575
collects/framework/private/color-prefs.ss
View File

@ -1,303 +1,296 @@
(module color-prefs mzscheme
(module color-prefs (lib "a-unit.ss")
(require (lib "class.ss")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "etc.ss")
(lib "mred.ss" "mred")
(lib "string-constant.ss" "string-constants")
"sig.ss")
(provide color-prefs@)
(define sc-choose-color (string-constant syntax-coloring-choose-color))
(import [prefix preferences: framework:preferences^]
[prefix editor: framework:editor^]
[prefix panel: framework:panel^]
[prefix canvas: framework:canvas^])
(export framework:color-prefs^)
(init-depend framework:editor^)
(define color-prefs@
(unit/sig framework:color-prefs^
(import [preferences : framework:preferences^]
[editor : framework:editor^]
[panel : framework:panel^]
[canvas : framework:canvas^])
(define standard-style-list-text% (editor:standard-style-list-mixin text%))
;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void
;; constructs a panel containg controls to configure the preferences panel.
;; BUG: style changes don't update the check boxes.
(define build-color-selection-panel
(opt-lambda (parent
pref-sym
style-name
example-text
[update-style-delta
(λ (func)
(let ([delta (preferences:get pref-sym)])
(func delta)
(preferences:set pref-sym delta)))])
(define hp (new horizontal-panel%
(parent parent)
(style '(border))
(stretchable-height #f)))
(define e (new (class standard-style-list-text%
(inherit change-style get-style-list)
(define/augment (after-insert pos offset)
(inner (void) after-insert pos offset)
(let ([style (send (get-style-list)
find-named-style
style-name)])
(change-style style pos (+ pos offset) #f)))
(super-new))))
(define c (new canvas:color%
(parent hp)
(editor e)
(style '(hide-hscroll
hide-vscroll))))
(define standard-style-list-text% (editor:standard-style-list-mixin text%))
(define (make-check name on off)
(let* ([c (λ (check command)
(if (send check get-value)
(update-style-delta on)
(update-style-delta off)))]
[check (make-object check-box% name hp c)])
check))
;; build-color-selection-panel : (is-a?/c area-container<%>) symbol string string -> void
;; constructs a panel containg controls to configure the preferences panel.
;; BUG: style changes don't update the check boxes.
(define build-color-selection-panel
(opt-lambda (parent
pref-sym
style-name
example-text
[update-style-delta
(λ (func)
(let ([delta (preferences:get pref-sym)])
(func delta)
(preferences:set pref-sym delta)))])
(define hp (new horizontal-panel%
(parent parent)
(style '(border))
(stretchable-height #f)))
(define e (new (class standard-style-list-text%
(inherit change-style get-style-list)
(define/augment (after-insert pos offset)
(inner (void) after-insert pos offset)
(let ([style (send (get-style-list)
find-named-style
style-name)])
(change-style style pos (+ pos offset) #f)))
(super-new))))
(define c (new canvas:color%
(parent hp)
(editor e)
(style '(hide-hscroll
hide-vscroll))))
(define (make-check name on off)
(let* ([c (λ (check command)
(if (send check get-value)
(update-style-delta on)
(update-style-delta off)))]
[check (make-object check-box% name hp c)])
check))
(define slant-check
(make-check (string-constant cs-italic)
(λ (delta)
(send delta set-style-on 'slant)
(send delta set-style-off 'base))
(λ (delta)
(send delta set-style-on 'base)
(send delta set-style-off 'slant))))
(define bold-check
(make-check (string-constant cs-bold)
(λ (delta)
(send delta set-weight-on 'bold)
(send delta set-weight-off 'base))
(λ (delta)
(send delta set-weight-on 'base)
(send delta set-weight-off 'bold))))
(define underline-check
(make-check (string-constant cs-underline)
(λ (delta)
(send delta set-underlined-on #t)
(send delta set-underlined-off #f))
(λ (delta)
(send delta set-underlined-off #t)
(send delta set-underlined-on #f))))
(define color-button
(and (>= (get-display-depth) 8)
(make-object button%
(string-constant cs-change-color)
hp
(λ (color-button evt)
(let* ([add (send (preferences:get pref-sym) get-foreground-add)]
[color (make-object color%
(send add get-r)
(send add get-g)
(send add get-b))]
[users-choice
(get-color-from-user
(format sc-choose-color example-text)
(send color-button get-top-level-window)
color)])
(when users-choice
(update-style-delta
(λ (delta)
(send delta set-delta-foreground users-choice)))))))))
(define style (send (send e get-style-list) find-named-style style-name))
(send c set-line-count 1)
(send c allow-tab-exit #t)
(send e insert example-text)
(send e set-position 0)
(send slant-check set-value (eq? (send style get-style) 'slant))
(send bold-check set-value (eq? (send style get-weight) 'bold))
(send underline-check set-value (send style get-underlined))))
(define slant-check
(make-check (string-constant cs-italic)
(λ (delta)
(send delta set-style-on 'slant)
(send delta set-style-off 'base))
(λ (delta)
(send delta set-style-on 'base)
(send delta set-style-off 'slant))))
(define bold-check
(make-check (string-constant cs-bold)
(λ (delta)
(send delta set-weight-on 'bold)
(send delta set-weight-off 'base))
(λ (delta)
(send delta set-weight-on 'base)
(send delta set-weight-off 'bold))))
(define underline-check
(make-check (string-constant cs-underline)
(λ (delta)
(send delta set-underlined-on #t)
(send delta set-underlined-off #f))
(λ (delta)
(send delta set-underlined-off #t)
(send delta set-underlined-on #f))))
(define color-button
(and (>= (get-display-depth) 8)
(make-object button%
(string-constant cs-change-color)
hp
(λ (color-button evt)
(let* ([add (send (preferences:get pref-sym) get-foreground-add)]
[color (make-object color%
(send add get-r)
(send add get-g)
(send add get-b))]
[users-choice
(get-color-from-user
(format (string-constant syntax-coloring-choose-color) example-text)
(send color-button get-top-level-window)
color)])
(when users-choice
(update-style-delta
(λ (delta)
(send delta set-delta-foreground users-choice)))))))))
(define style (send (send e get-style-list) find-named-style style-name))
(define (add/mult-set m v)
(send m set (car v) (cadr v) (caddr v)))
(send c set-line-count 1)
(send c allow-tab-exit #t)
(define (add/mult-get m)
(let ([b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)])
(send m get b1 b2 b3)
(map unbox (list b1 b2 b3))))
(send e insert example-text)
(send e set-position 0)
(define style-delta-get/set
(list (cons (λ (x) (send x get-alignment-off))
(λ (x v) (send x set-alignment-off v)))
(cons (λ (x) (send x get-alignment-on))
(λ (x v) (send x set-alignment-on v)))
(cons (λ (x) (add/mult-get (send x get-background-add)))
(λ (x v) (add/mult-set (send x get-background-add) v)))
(cons (λ (x) (add/mult-get (send x get-background-mult)))
(λ (x v) (add/mult-set (send x get-background-mult) v)))
(cons (λ (x) (send x get-face))
(λ (x v) (send x set-face v)))
(cons (λ (x) (send x get-family))
(λ (x v) (send x set-family v)))
(cons (λ (x) (add/mult-get (send x get-foreground-add)))
(λ (x v) (add/mult-set (send x get-foreground-add) v)))
(cons (λ (x) (add/mult-get (send x get-foreground-mult)))
(λ (x v) (add/mult-set (send x get-foreground-mult) v)))
(cons (λ (x) (send x get-size-add))
(λ (x v) (send x set-size-add v)))
(cons (λ (x) (send x get-size-mult))
(λ (x v) (send x set-size-mult v)))
(cons (λ (x) (send x get-style-off))
(λ (x v) (send x set-style-off v)))
(cons (λ (x) (send x get-style-on))
(λ (x v) (send x set-style-on v)))
(cons (λ (x) (send x get-underlined-off))
(λ (x v) (send x set-underlined-off v)))
(cons (λ (x) (send x get-underlined-on))
(λ (x v) (send x set-underlined-on v)))
(cons (λ (x) (send x get-weight-off))
(λ (x v) (send x set-weight-off v)))
(cons (λ (x) (send x get-weight-on))
(λ (x v) (send x set-weight-on v)))))
(define (marshall-style style)
(map (λ (fs) ((car fs) style)) style-delta-get/set))
(define (unmarshall-style info)
(let ([style (make-object style-delta%)])
(for-each (λ (fs v) ((cdr fs) style v)) style-delta-get/set info)
style))
(define (make-style-delta color bold? underline? italic?)
(let ((sd (make-object style-delta%)))
(send sd set-delta-foreground color)
(cond
(bold?
(send sd set-weight-on 'bold)
(send sd set-weight-off 'base))
(else
(send sd set-weight-on 'base)
(send sd set-weight-off 'bold)))
(send sd set-underlined-on underline?)
(send sd set-underlined-off (not underline?))
(cond
(italic?
(send sd set-style-on 'italic)
(send sd set-style-off 'base))
(else
(send sd set-style-on 'base)
(send sd set-style-off 'italic)))
sd))
(define (add-background-preferences-panel)
(preferences:add-panel
(list (string-constant preferences-colors)
(string-constant background-color))
(λ (parent)
(let ([vp (new vertical-panel% (parent parent))])
(add-solid-color-config (string-constant background-color)
vp
'framework:basic-canvas-background)
(add-solid-color-config (string-constant paren-match-color)
vp
'framework:paren-match-color)
(build-text-foreground-selection-panel vp
'framework:default-text-color
(editor:get-default-color-style-name)
(string-constant default-text-color))))))
(define (build-text-foreground-selection-panel parent pref-sym style-name example-text)
(define hp (new horizontal-panel%
(parent parent)
(style '(border))
(stretchable-height #f)))
(define e (new (class standard-style-list-text%
(inherit change-style get-style-list)
(define/augment (after-insert pos offset)
(inner (void) after-insert pos offset)
(let ([style (send (get-style-list)
find-named-style
style-name)])
(change-style style pos (+ pos offset) #f)))
(super-new))))
(define c (new canvas:color%
(parent hp)
(editor e)
(style '(hide-hscroll
hide-vscroll))))
(define color-button
(and (>= (get-display-depth) 8)
(make-object button%
(string-constant cs-change-color)
hp
(λ (color-button evt)
(let ([users-choice
(get-color-from-user
(format sc-choose-color example-text)
(send color-button get-top-level-window)
(preferences:get pref-sym))])
(when users-choice
(preferences:set pref-sym users-choice)))))))
(define style (send (send e get-style-list) find-named-style style-name))
(send c set-line-count 1)
(send c allow-tab-exit #t)
(send e insert example-text)
(send e set-position 0))
(define (add-solid-color-config label parent pref-id)
(letrec ([panel (new vertical-panel% (parent parent) (stretchable-height #f))]
[hp (new horizontal-panel% (parent panel) (stretchable-height #f))]
[msg (new message% (parent hp) (label label))]
[canvas
(new canvas%
(parent hp)
(paint-callback
(λ (c dc)
(draw (preferences:get pref-id)))))]
[draw
(λ (clr)
(let ([dc (send canvas get-dc)])
(let-values ([(w h) (send canvas get-client-size)])
(send dc set-brush (send the-brush-list find-or-create-brush clr 'solid))
(send dc set-pen (send the-pen-list find-or-create-pen clr 1 'solid))
(send dc draw-rectangle 0 0 w h))))]
[button
(new button%
(label (string-constant cs-change-color))
(parent hp)
(callback
(λ (x y)
(let ([color (get-color-from-user
(string-constant choose-a-background-color)
(send hp get-top-level-window)
(preferences:get pref-id))])
(when color
(preferences:set pref-id color))))))])
(preferences:add-callback
pref-id
(λ (p v) (draw v)))
panel))
;; add-to-preferences-panel : string (vertical-panel -> void) -> void
(define (add-to-preferences-panel panel-name func)
(preferences:add-panel
(list (string-constant preferences-colors) panel-name)
(λ (parent)
(let ([panel (new vertical-panel% (parent parent))])
(func panel)
panel))))
;; see docs
(define (register-color-pref pref-name style-name color)
(let ([sd (new style-delta%)])
(send sd set-delta-foreground color)
(preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%))))
(preferences:set-un/marshall pref-name marshall-style unmarshall-style)
(preferences:add-callback pref-name
(λ (sym v)
(editor:set-standard-style-list-delta style-name v)))
(editor:set-standard-style-list-delta style-name (preferences:get pref-name))))))
(send slant-check set-value (eq? (send style get-style) 'slant))
(send bold-check set-value (eq? (send style get-weight) 'bold))
(send underline-check set-value (send style get-underlined))))
(define (add/mult-set m v)
(send m set (car v) (cadr v) (caddr v)))
(define (add/mult-get m)
(let ([b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)])
(send m get b1 b2 b3)
(map unbox (list b1 b2 b3))))
(define style-delta-get/set
(list (cons (λ (x) (send x get-alignment-off))
(λ (x v) (send x set-alignment-off v)))
(cons (λ (x) (send x get-alignment-on))
(λ (x v) (send x set-alignment-on v)))
(cons (λ (x) (add/mult-get (send x get-background-add)))
(λ (x v) (add/mult-set (send x get-background-add) v)))
(cons (λ (x) (add/mult-get (send x get-background-mult)))
(λ (x v) (add/mult-set (send x get-background-mult) v)))
(cons (λ (x) (send x get-face))
(λ (x v) (send x set-face v)))
(cons (λ (x) (send x get-family))
(λ (x v) (send x set-family v)))
(cons (λ (x) (add/mult-get (send x get-foreground-add)))
(λ (x v) (add/mult-set (send x get-foreground-add) v)))
(cons (λ (x) (add/mult-get (send x get-foreground-mult)))
(λ (x v) (add/mult-set (send x get-foreground-mult) v)))
(cons (λ (x) (send x get-size-add))
(λ (x v) (send x set-size-add v)))
(cons (λ (x) (send x get-size-mult))
(λ (x v) (send x set-size-mult v)))
(cons (λ (x) (send x get-style-off))
(λ (x v) (send x set-style-off v)))
(cons (λ (x) (send x get-style-on))
(λ (x v) (send x set-style-on v)))
(cons (λ (x) (send x get-underlined-off))
(λ (x v) (send x set-underlined-off v)))
(cons (λ (x) (send x get-underlined-on))
(λ (x v) (send x set-underlined-on v)))
(cons (λ (x) (send x get-weight-off))
(λ (x v) (send x set-weight-off v)))
(cons (λ (x) (send x get-weight-on))
(λ (x v) (send x set-weight-on v)))))
(define (marshall-style style)
(map (λ (fs) ((car fs) style)) style-delta-get/set))
(define (unmarshall-style info)
(let ([style (make-object style-delta%)])
(for-each (λ (fs v) ((cdr fs) style v)) style-delta-get/set info)
style))
(define (make-style-delta color bold? underline? italic?)
(let ((sd (make-object style-delta%)))
(send sd set-delta-foreground color)
(cond
(bold?
(send sd set-weight-on 'bold)
(send sd set-weight-off 'base))
(else
(send sd set-weight-on 'base)
(send sd set-weight-off 'bold)))
(send sd set-underlined-on underline?)
(send sd set-underlined-off (not underline?))
(cond
(italic?
(send sd set-style-on 'italic)
(send sd set-style-off 'base))
(else
(send sd set-style-on 'base)
(send sd set-style-off 'italic)))
sd))
(define (add-background-preferences-panel)
(preferences:add-panel
(list (string-constant preferences-colors)
(string-constant background-color))
(λ (parent)
(let ([vp (new vertical-panel% (parent parent))])
(add-solid-color-config (string-constant background-color)
vp
'framework:basic-canvas-background)
(add-solid-color-config (string-constant paren-match-color)
vp
'framework:paren-match-color)
(build-text-foreground-selection-panel vp
'framework:default-text-color
(editor:get-default-color-style-name)
(string-constant default-text-color))))))
(define (build-text-foreground-selection-panel parent pref-sym style-name example-text)
(define hp (new horizontal-panel%
(parent parent)
(style '(border))
(stretchable-height #f)))
(define e (new (class standard-style-list-text%
(inherit change-style get-style-list)
(define/augment (after-insert pos offset)
(inner (void) after-insert pos offset)
(let ([style (send (get-style-list)
find-named-style
style-name)])
(change-style style pos (+ pos offset) #f)))
(super-new))))
(define c (new canvas:color%
(parent hp)
(editor e)
(style '(hide-hscroll
hide-vscroll))))
(define color-button
(and (>= (get-display-depth) 8)
(make-object button%
(string-constant cs-change-color)
hp
(λ (color-button evt)
(let ([users-choice
(get-color-from-user
(format (string-constant syntax-coloring-choose-color) example-text)
(send color-button get-top-level-window)
(preferences:get pref-sym))])
(when users-choice
(preferences:set pref-sym users-choice)))))))
(define style (send (send e get-style-list) find-named-style style-name))
(send c set-line-count 1)
(send c allow-tab-exit #t)
(send e insert example-text)
(send e set-position 0))
(define (add-solid-color-config label parent pref-id)
(letrec ([panel (new vertical-panel% (parent parent) (stretchable-height #f))]
[hp (new horizontal-panel% (parent panel) (stretchable-height #f))]
[msg (new message% (parent hp) (label label))]
[canvas
(new canvas%
(parent hp)
(paint-callback
(λ (c dc)
(draw (preferences:get pref-id)))))]
[draw
(λ (clr)
(let ([dc (send canvas get-dc)])
(let-values ([(w h) (send canvas get-client-size)])
(send dc set-brush (send the-brush-list find-or-create-brush clr 'solid))
(send dc set-pen (send the-pen-list find-or-create-pen clr 1 'solid))
(send dc draw-rectangle 0 0 w h))))]
[button
(new button%
(label (string-constant cs-change-color))
(parent hp)
(callback
(λ (x y)
(let ([color (get-color-from-user
(string-constant choose-a-background-color)
(send hp get-top-level-window)
(preferences:get pref-id))])
(when color
(preferences:set pref-id color))))))])
(preferences:add-callback
pref-id
(λ (p v) (draw v)))
panel))
;; add-to-preferences-panel : string (vertical-panel -> void) -> void
(define (add-to-preferences-panel panel-name func)
(preferences:add-panel
(list (string-constant preferences-colors) panel-name)
(λ (parent)
(let ([panel (new vertical-panel% (parent parent))])
(func panel)
panel))))
;; see docs
(define (register-color-pref pref-name style-name color)
(let ([sd (new style-delta%)])
(send sd set-delta-foreground color)
(preferences:set-default pref-name sd (λ (x) (is-a? x style-delta%))))
(preferences:set-un/marshall pref-name marshall-style unmarshall-style)
(preferences:add-callback pref-name
(λ (sym v)
(editor:set-standard-style-list-delta style-name v)))
(editor:set-standard-style-list-delta style-name (preferences:get pref-name))))

1412
collects/framework/private/color.ss
View File

File diff suppressed because it is too large Load Diff

20
collects/framework/private/comment-box.ss
View File

@ -1,24 +1,18 @@
(module comment-box mzscheme
(module comment-box (lib "a-unit.ss")
(require (lib "class.ss")
(lib "etc.ss")
(lib "mred.ss" "mred")
(lib "unitsig.ss")
"sig.ss"
"../decorated-editor-snip.ss"
(lib "include-bitmap.ss" "mrlib")
(lib "string-constant.ss" "string-constants"))
(provide comment-box@)
(define comment-box@
(unit/sig framework:comment-box^
(import [text : framework:text^]
[scheme : framework:scheme^]
[keymap : framework:keymap^])
(rename [-snip% snip%]
[-text% text%])
(import [prefix text: framework:text^]
[prefix scheme: framework:scheme^]
[prefix keymap: framework:keymap^])
(export (rename framework:comment-box^
(-snip% snip%)))
(define snipclass%
(class decorated-editor-snipclass%
@ -127,4 +121,4 @@
(make-special-comment "comment"))
(super-instantiate ())
(inherit set-snipclass)
(set-snipclass snipclass))))))
(set-snipclass snipclass))))

40
collects/framework/private/editor.ss
View File

@ -1,7 +1,6 @@
(module editor mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(module editor (lib "a-unit.ss")
(require (lib "class.ss")
(lib "string-constant.ss" "string-constants")
"sig.ss"
"../gui-utils.ss"
@ -9,24 +8,21 @@
(lib "mred-sig.ss" "mred")
(lib "file.ss"))
(provide editor@)
(define editor@
(unit/sig framework:editor^
(import mred^
[autosave : framework:autosave^]
[finder : framework:finder^]
[path-utils : framework:path-utils^]
[keymap : framework:keymap^]
[icon : framework:icon^]
[preferences : framework:preferences^]
[text : framework:text^]
[pasteboard : framework:pasteboard^]
[frame : framework:frame^]
[handler : framework:handler^])
(rename [-keymap<%> keymap<%>])
(import mred^
[prefix autosave: framework:autosave^]
[prefix finder: framework:finder^]
[prefix path-utils: framework:path-utils^]
[prefix keymap: framework:keymap^]
[prefix icon: framework:icon^]
[prefix preferences: framework:preferences^]
[prefix text: framework:text^]
[prefix pasteboard: framework:pasteboard^]
[prefix frame: framework:frame^]
[prefix handler: framework:handler^])
(export (rename framework:editor^
[-keymap<%> keymap<%>]))
(init-depend mred^ framework:autosave^)
;; renaming, for editor-mixin where get-file is shadowed by a method.
(define mred:get-file get-file)
@ -600,4 +596,4 @@
(set! callback-running? #f))
#f))))
'framework:update-lock-icon))
(super-instantiate ()))))))
(super-instantiate ()))))

18
collects/framework/private/exit.ss
View File

@ -1,6 +1,5 @@
(module exit mzscheme
(require (lib "unitsig.ss")
(lib "string-constant.ss" "string-constants")
(module exit (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
(lib "class.ss")
"sig.ss"
"../gui-utils.ss"
@ -8,13 +7,10 @@
(lib "file.ss")
(lib "etc.ss"))
(provide exit@)
(define exit@
(unit/sig framework:exit^
(import mred^
[preferences : framework:preferences^])
(rename (-exit exit))
(import mred^
[prefix preferences: framework:preferences^])
(export (rename framework:exit^
(-exit exit)))
(define can?-callbacks '())
(define on-callbacks '())
@ -79,4 +75,4 @@
(exit)
(set! is-exiting? #f)))]
[else
(set! is-exiting? #f)])))))
(set! is-exiting? #f)])))

23
collects/framework/private/exn.ss
View File

@ -1,18 +1,13 @@
(module exn mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(module exn (lib "a-unit.ss")
(require (lib "class.ss")
"sig.ss"
(lib "mred-sig.ss" "mred"))
(provide exn@)
(import)
(export (rename framework:exn^
[struct:-exn struct:exn]
[make--exn make-exn]
[-exn? exn?]))
(define exn@
(unit/sig framework:exn^
(import)
(rename [struct:-exn struct:exn]
[make--exn make-exn]
[-exn? exn?])
(define-struct (-exn exn) ())
(define-struct (unknown-preference exn) ()))))
(define-struct (-exn exn) ())
(define-struct (unknown-preference exn) ()))

19
collects/framework/private/finder.ss
View File

@ -1,7 +1,6 @@
(module finder mzscheme
(module finder (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
"sig.ss"
"../gui-utils.ss"
(lib "class.ss")
@ -11,16 +10,14 @@
(lib "file.ss")
(lib "etc.ss"))
(provide finder@)
(define finder@
(unit/sig framework:finder^
(import mred^
[preferences : framework:preferences^]
[keymap : framework:keymap^])
(import mred^
[prefix preferences: framework:preferences^]
[prefix keymap: framework:keymap^])
(rename [-put-file put-file]
[-get-file get-file])
(export (rename framework:finder^
[-put-file put-file]
[-get-file get-file]))
(define dialog-parent-parameter (make-parameter #f))
@ -106,4 +103,4 @@
(apply (case (preferences:get 'framework:file-dialogs)
[(std) std-get-file]
[(common) common-get-file])
args))))))
args))))

52
collects/framework/private/frame.ss
View File

@ -1,7 +1,6 @@
(module frame mzscheme
(module frame (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "class.ss")
(lib "include.ss")
"sig.ss"
@ -12,32 +11,31 @@
(lib "file.ss")
(lib "etc.ss"))
(provide frame@)
(import mred^
[prefix group: framework:group^]
[prefix preferences: framework:preferences^]
[prefix icon: framework:icon^]
[prefix handler: framework:handler^]
[prefix application: framework:application^]
[prefix panel: framework:panel^]
[prefix finder: framework:finder^]
[prefix keymap: framework:keymap^]
[prefix text: framework:text^]
[prefix pasteboard: framework:pasteboard^]
[prefix editor: framework:editor^]
[prefix canvas: framework:canvas^]
[prefix menu: framework:menu^]
[prefix scheme: framework:scheme^]
[prefix exit: framework:exit^]
[prefix comment-box: framework:comment-box^])
(define frame@
(unit/sig framework:frame^
(import mred^
[group : framework:group^]
[preferences : framework:preferences^]
[icon : framework:icon^]
[handler : framework:handler^]
[application : framework:application^]
[panel : framework:panel^]
[finder : framework:finder^]
[keymap : framework:keymap^]
[text : framework:text^]
[pasteboard : framework:pasteboard^]
[editor : framework:editor^]
[canvas : framework:canvas^]
[menu : framework:menu^]
[scheme : framework:scheme^]
[exit : framework:exit^]
[comment-box : framework:comment-box^])
(rename [-editor<%> editor<%>]
[-pasteboard% pasteboard%]
[-text% text%])
(export (rename framework:frame^
[-editor<%> editor<%>]
[-pasteboard% pasteboard%]
[-text% text%]))
(init-depend mred^ framework:text^)
(define (reorder-menus frame)
(define items (send (send frame get-menu-bar) get-items))
(define (find-menu name)
@ -2374,4 +2372,4 @@
(define searchable% (searchable-text-mixin (searchable-mixin -text%)))
(define delegate% (delegate-mixin searchable%))
(define -pasteboard% (pasteboard-mixin open-here%)))))
(define -pasteboard% (pasteboard-mixin open-here%)))

26
collects/framework/private/group.ss
View File

@ -1,25 +1,21 @@
(module group mzscheme
(module group (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "class.ss")
"sig.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
(lib "list.ss")
(lib "file.ss"))
(provide group@)
(define group@
(unit/sig framework:group^
(import mred^
[application : framework:application^]
[frame : framework:frame^]
[preferences : framework:preferences^]
[text : framework:text^]
[canvas : framework:canvas^]
[menu : framework:menu^])
(import mred^
[prefix application: framework:application^]
[prefix frame: framework:frame^]
[prefix preferences: framework:preferences^]
[prefix text: framework:text^]
[prefix canvas: framework:canvas^]
[prefix menu: framework:menu^])
(export framework:group^)
(define-struct frame (frame id))
@ -322,4 +318,4 @@
(internal-get-the-frame-group)))
(define (get-the-frame-group)
(internal-get-the-frame-group)))))
(internal-get-the-frame-group)))

28
collects/framework/private/handler.ss
View File

@ -1,7 +1,6 @@
(module handler mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(module handler (lib "a-unit.ss")
(require (lib "class.ss")
(lib "list.ss")
(lib "hierlist.ss" "hierlist")
"sig.ss"
@ -10,17 +9,16 @@
(lib "file.ss")
(lib "string-constant.ss" "string-constants"))
(provide handler@)
(define handler@
(unit/sig framework:handler^
(import mred^
[finder : framework:finder^]
[group : framework:group^]
[text : framework:text^]
[preferences : framework:preferences^]
[frame : framework:frame^])
(import mred^
[prefix finder: framework:finder^]
[prefix group: framework:group^]
[prefix text: framework:text^]
[prefix preferences: framework:preferences^]
[prefix frame: framework:frame^])
(export framework:handler^)
(init-depend framework:frame^)
(define-struct handler (name extension handler))
(define format-handlers '())
@ -392,4 +390,4 @@
(send *open-directory*
set-from-file! file))
(and file
(edit-file file))))))))
(edit-file file))))))

16
collects/framework/private/icon.ss
View File

@ -1,17 +1,13 @@
(module icon mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(module icon (lib "a-unit.ss")
(require (lib "class.ss")
(lib "include-bitmap.ss" "mrlib")
"bday.ss"
"sig.ss"
(lib "mred-sig.ss" "mred"))
(import mred^)
(export framework:icon^)
(provide icon@)
(define icon@
(unit/sig framework:icon^
(import mred^)
(define eof-bitmap (delay (include-bitmap (lib "eof.gif" "icons"))))
(define (get-eof-bitmap) (force eof-bitmap))
@ -73,4 +69,4 @@
(force
(if (mrf-bday?)
mrf-off-bitmap
gc-off-bitmap))))))
gc-off-bitmap))))

27
collects/framework/private/keymap.ss
View File

@ -1,26 +1,23 @@
(module keymap mzscheme
(module keymap (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss")
(lib "class.ss")
(lib "list.ss")
(lib "mred-sig.ss" "mred")
(lib "match.ss")
"sig.ss")
(provide keymap@)
(import mred^
[prefix preferences: framework:preferences^]
[prefix finder: framework:finder^]
[prefix handler: framework:handler^]
[prefix frame: framework:frame^]
[prefix editor: framework:editor^])
(export (rename framework:keymap^
[-get-file get-file]))
(init-depend mred^)
(define keymap@
(unit/sig framework:keymap^
(import mred^
[preferences : framework:preferences^]
[finder : framework:finder^]
[handler : framework:handler^]
[frame : framework:frame^]
[editor : framework:editor^])
(rename [-get-file get-file])
(define user-keybindings-files (make-hash-table 'equal))
(define (add-user-keybindings-file spec)
@ -1342,4 +1339,4 @@
(λ (keymap)
(send keymap chain-to-keymap global #t)
(ctki keymap))])
(thunk)))))))
(thunk)))))

30
collects/framework/private/main.ss
View File

@ -1,24 +1,22 @@
(module main mzscheme
(require (lib "unitsig.ss")
(lib "class.ss")
(module main (lib "a-unit.ss")
(require (lib "class.ss")
"sig.ss"
"../gui-utils.ss"
(lib "string-constant.ss" "string-constants")
(lib "mred-sig.ss" "mred"))
(provide main@)
(import mred^
[prefix preferences: framework:preferences^]
[prefix exit: framework:exit^]
[prefix group: framework:group^]
[prefix handler: framework:handler^]
[prefix editor: framework:editor^]
[prefix color-prefs: framework:color-prefs^]
[prefix scheme: framework:scheme^])
(export framework:main^)
(init-depend framework:preferences^ framework:exit^ framework:editor^
framework:color-prefs^ framework:scheme^)
(define main@
(unit/sig framework:main^
(import mred^
[preferences : framework:preferences^]
[exit : framework:exit^]
[group : framework:group^]
[handler : framework:handler^]
[editor : framework:editor^]
[color-prefs : framework:color-prefs^]
[scheme : framework:scheme^])
(application-preferences-handler (λ () (preferences:show-dialog)))
(preferences:set-default 'framework:square-bracket:cond/offset
@ -319,4 +317,4 @@
;; the application.
;(preferences:set 'framework:file-dialogs 'std)
(void))))
(void))

Some files were not shown because too many files have changed in this diff Show More