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

more v4-isms

Browse Source 
svn: r8523
This commit is contained in:
Eli Barzilay 2008-02-04 17:00:41 +00:00
parent d113956877
commit 5a08a34f73
16 changed files with 253 additions and 3411 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/swindle/base.ss
View File

@ -3,7 +3,7 @@
;;> The `base' module defines some basic low-level syntactic extensions to
;;> MzScheme. It can be used by itself to get these extensions.
(module base mzscheme
#lang mzscheme
(provide (all-from-except mzscheme
#%module-begin #%top #%app define let let* letrec lambda
@ -19,16 +19,15 @@
(datum->syntax-object
(quote-syntax here)
(list* (quote-syntax #%plain-module-begin)
(datum->syntax-object stx
(list (quote-syntax require-for-syntax)
'(lib "base.ss" "swindle")))
(datum->syntax-object
stx (list (quote-syntax require-for-syntax) 'swindle/base))
(cdr e))
stx)
(raise-syntax-error #f "bad syntax" stx)))
;; This doesn't work anymore (from 203.4)
;; (syntax-rules ()
;; [(_ . body) (#%plain-module-begin
;; (require-for-syntax (lib "base.ss" "swindle")) . body)])
;; (require-for-syntax swindle/base) . body)])
)
;;>> (#%top . id)
@ -593,5 +592,3 @@
[else
(loop (cddr as)
(if (memq (car as) outs) r (list* (cadr as) (car as) r)))])))
)

8
collects/swindle/clos.ss
View File

@ -3,10 +3,10 @@
;;> This module contains only syntax definitions, which makes Swindle closer
;;> to CLOS -- making the object system much more convenient to use.
(module clos (lib "turbo.ss" "swindle")
#lang s-exp swindle/turbo
(require (lib "tiny-clos.ss" "swindle"))
(provide (all-from (lib "tiny-clos.ss" "swindle")))
(require swindle/tiny-clos)
(provide (all-from swindle/tiny-clos))
;;; ---------------------------------------------------------------------------
;;; General helpers
@ -730,5 +730,3 @@
(provide defgeneric*) (make-provide-syntax defgeneric defgeneric*)
(provide defclass*) (make-provide-syntax defclass defclass*)
(provide defentityclass*) (make-provide-syntax defentityclass defentityclass*)
)

51
collects/swindle/custom.ss
View File

@ -24,32 +24,33 @@
;;; not things that can be made into a module -- a teachpack is better for
;;; those.
(module custom (lib "swindle.ss" "swindle")
;; provide all swindle, minus `lambda' which is overriden to `method'
(provide (all-from-except (lib "swindle.ss" "swindle") lambda))
(provide (rename lambda~ lambda))
(defsubst lambda~ method)
;; some default customizations
(*make-safely* #t)
;; set some syntax parameters -- must use eval!
(eval #'(begin
;; simple defclass forms:
(-defclass-auto-initargs-
(;; auto acccessors, constructors, and predicates
:auto #t
;; first two things after a slot name are type and initvalue
:default-slot-options '(:type :initvalue)
;; printed representation of objects shows slot contents
:printer print-object-with-slots))
;; set the accessor names made by the above
(-defclass-autoaccessors-naming- :class-slot)
;; always use an explicit generic
(-defmethod-create-generics- #f)
;; use defgeneric + add-method for accessors (since defmethod now
;; wouldn't create the generic)
(-defclass-accessor-mode- :defgeneric))))
#lang swindle
;;; To make thins even better, it is best to change preferences so Swindle
;; provide all swindle, minus `lambda' which is overriden to `method'
(provide (all-from-except swindle lambda))
(provide (rename lambda~ lambda))
(defsubst lambda~ method)
;; some default customizations
(*make-safely* #t)
;; set some syntax parameters -- must use eval!
(eval #'(begin
;; simple defclass forms:
(-defclass-auto-initargs-
(;; auto acccessors, constructors, and predicates
:auto #t
;; first two things after a slot name are type and initvalue
:default-slot-options '(:type :initvalue)
;; printed representation of objects shows slot contents
:printer print-object-with-slots))
;; set the accessor names made by the above
(-defclass-autoaccessors-naming- :class-slot)
;; always use an explicit generic
(-defmethod-create-generics- #f)
;; use defgeneric + add-method for accessors (since defmethod now
;; wouldn't create the generic)
(-defclass-accessor-mode- :defgeneric)))
;;; To make things even better, it is best to change preferences so Swindle
;;; syntax get indented correctly. For this, create the default preference
;;; file "plt/collects/defaults/plt-prefs.ss", and in it you can put any
;;; specific preferences you want as the defaults for people who run the system

6
collects/swindle/extra.ss
View File

@ -1,9 +1,9 @@
(module extra (lib "turbo.ss" "swindle")
#lang s-exp swindle/turbo
;;> This module defines some additional useful functionality which requires
;;> Swindle.
(require (lib "clos.ss" "swindle"))
(require swindle/clos)
;;; ---------------------------------------------------------------------------
;;; A convenient `defstruct'
@ -969,5 +969,3 @@
(ui-question str args "Ok/Cancel" 'ok '(ok-cancel) #\o #\c))
(define* (yes/no? str . args)
(ui-question str args "Yes/No" 'yes '(yes-no) #\y #\n))
)

1887
collects/swindle/html-doc.txt
View File

File diff suppressed because it is too large Load Diff

1247
collects/swindle/html.ss
View File

File diff suppressed because it is too large Load Diff

10
collects/swindle/info.ss
View File

@ -3,14 +3,10 @@
(module info setup/infotab
;;
(define name "Swindle")
(define blurb
'("Swindle extensions for MzScheme -- CLOS and more."))
(define help-desk-message
"Mz/Mr: (require (lib \"swindle.ss\" \"swindle\"))")
(define blurb '("Swindle extensions for MzScheme -- CLOS and more."))
(define help-desk-message "Mz/Mr: (require (lib \"swindle.ss\" \"swindle\"))")
(define mzscheme-launcher-names '("swindle"))
(define mzscheme-launcher-flags
'(("-me"
"(namespace-require/copy (quote (lib \"swindle.ss\" \"swindle\")))")))
(define mzscheme-launcher-flags '(("-li" "swindle")))
;;
;; This simple interface is not enough, use tool.ss instead
;; (define drscheme-language-modules

2
collects/swindle/lang/reader.ss Normal file
View File

@ -0,0 +1,2 @@
#lang s-exp syntax/module-reader
swindle

17
collects/swindle/main.ss Normal file
View File

@ -0,0 +1,17 @@
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
;;> This module combines all modules to form the Swindle language module.
;;>
;;> Note that it does not re-define `#%module-begin', so the language used
;;> for transformers is still the one defined by `turbo'.
#lang s-exp swindle/turbo
(require swindle/clos swindle/extra)
(provide (all-from swindle/turbo)
(all-from swindle/clos)
(all-from swindle/extra))
(current-prompt-read
(let ([old-prompt-read (current-prompt-read)])
(lambda () (display "=") (flush-output) (old-prompt-read))))
(install-swindle-printer)

15
collects/swindle/misc.ss
View File

@ -3,14 +3,11 @@
;;> A lot of miscellaneous functionality that is needed for Swindle, or
;;> useful by itself.
(module misc (lib "base.ss" "swindle")
#lang s-exp swindle/base
(require (lib "list.ss"))
(provide (all-from (lib "list.ss")))
(require (lib "etc.ss"))
(provide (all-from (lib "etc.ss")))
(require (all-except (lib "string.ss")))
(provide (all-from (lib "string.ss")))
(require mzlib/list) (provide (all-from mzlib/list))
(require mzlib/etc) (provide (all-from mzlib/etc))
(require mzlib/string) (provide (all-from mzlib/string))
;; ----------------------------------------------------------------------------
;;>>... Convenient syntax definitions
@ -157,7 +154,7 @@
;;> with `defsubst' above).
;;> * A `letmacro' form for local macros is provided.
(require-for-syntax (lib "dmhelp.ss" "mzlib" "private"))
(require-for-syntax mzlib/private/dmhelp)
(provide defmacro letmacro)
(define-syntaxes (defmacro letmacro)
(let ()
@ -1900,5 +1897,3 @@
[(_ str clause ...)
#`(let ([s str])
(cond #,@(map do-clause (syntax->list #'(clause ...)))))]))
)

4
collects/swindle/patterns.ss
View File

@ -1,4 +1,4 @@
(module patterns mzscheme
#lang mzscheme
(provide (all-from-except mzscheme
define-values
@ -263,5 +263,3 @@
;; (require foo)
;; (define a (make-point 1 2))
;; (let ([(make-point x y) a]) (+ x y))
)

4
collects/swindle/setf.ss
View File

@ -8,7 +8,7 @@
;;> this just defines the basic functionality, the `misc' module defines
;;> many common setters.
(module setf mzscheme
#lang mzscheme
;;>> (setf! place value ...)
;;> Expand `(setf! (foo ...) v)' to `(set-foo! ... v)'. The generated
@ -274,5 +274,3 @@
(lambda (p)
#`(let ([p1 #,p])
(begin0 (car p1) (setf! #,p (cdr p1))))))])))))
)

21
collects/swindle/swindle.ss
View File

@ -1,21 +0,0 @@
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
;;> This module combines all modules to form the Swindle language module.
;;>
;;> Note that it does not re-define `#%module-begin', so the language used
;;> for transformers is still the one defined by `turbo'.
(module swindle (lib "turbo.ss" "swindle")
(require (lib "clos.ss" "swindle")
(lib "extra.ss" "swindle"))
(provide (all-from (lib "turbo.ss" "swindle"))
(all-from (lib "clos.ss" "swindle"))
(all-from (lib "extra.ss" "swindle")))
(current-prompt-read
(let ([old-prompt-read (current-prompt-read)])
(lambda () (display "=") (flush-output) (old-prompt-read))))
(install-swindle-printer)
;; This comes out ugly in DrScheme.
;; (printf
;; "Welcome to Swindle -- Eli Barzilay: Maze is Life! (eli@barzilay.org)\n")
)

6
collects/swindle/tiny-clos.ss
View File

@ -30,7 +30,7 @@
;;; DAMAGES.
;;; ***************************************************************************
(module tiny-clos (lib "base.ss" "swindle")
#lang s-exp swindle/base
;;; A very simple CLOS-like language, embedded in Scheme, with a simple MOP.
;;; The features of the default base language are:
@ -116,7 +116,7 @@
;;; OK, now let's get going. But, as usual, before we can do anything
;;; interesting, we have to muck around for a bit first. First, we need to
;;; load the support library. [-- replaced with a module.]
(require (lib "misc.ss" "swindle"))
(require swindle/misc)
;; This is a convenient function for raising exceptions
(define (raise* exn-maker fmt . args)
@ -2336,5 +2336,3 @@
;;> compute-methods
;;> compute-method-more-specific?
;;> compute-apply-methods
)

321
collects/swindle/tool.ss
View File

@ -1,162 +1,163 @@
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
;; This allows adding a Swindle icon on startup.
(module tool mzscheme
(require (lib "unit.ss")
(lib "tool.ss" "drscheme")
(lib "class.ss")
(lib "list.ss")
(lib "mred.ss" "mred")
(lib "sendurl.ss" "net")
(lib "string-constant.ss" "string-constants"))
(provide tool@)
(define tool@
(unit (import drscheme:tool^) (export drscheme:tool-exports^)
;; Swindle languages
(define (swindle-language module* name* entry-name* num* one-line* url*)
(class (drscheme:language:module-based-language->language-mixin
(drscheme:language:simple-module-based-language->module-based-language-mixin
(class* object%
(drscheme:language:simple-module-based-language<%>)
(define/public (get-language-numbers) `(-1000 2000 ,num*))
(define/public (get-language-position)
(list (string-constant legacy-languages)
"Swindle" entry-name*))
(define/public (get-module) module*)
(define/public (get-one-line-summary) one-line*)
(define/public (get-language-url) url*)
(define/public (get-reader)
(lambda (src port)
(let ([v (read-syntax src port)])
(if (eof-object? v)
v
(namespace-syntax-introduce v)))))
(super-instantiate ()))))
(define/override (use-namespace-require/copy?) #t)
(define/override (default-settings)
(drscheme:language:make-simple-settings
#t 'current-print 'mixed-fraction-e #f #t 'debug))
(define/override (get-language-name) name*)
(define/override (config-panel parent)
(let* ([make-panel
(lambda (msg contents)
(make-object message% msg parent)
(let ([p (instantiate vertical-panel% ()
(parent parent)
(style '(border))
(alignment '(left center)))])
(if (string? contents)
(make-object message% contents p)
(contents p))))]
[title-panel
(instantiate horizontal-panel% ()
(parent parent)
(alignment '(center center)))]
[title-pic
(make-object message%
(make-object bitmap%
(build-path (collection-path "swindle")
"swindle-logo.png"))
title-panel)]
[title (let ([p (instantiate vertical-panel% ()
(parent title-panel)
(alignment '(left center)))])
(make-object message% (format "Swindle") p)
(make-object message% (format "Setup") p)
p)]
[input-sensitive?
(make-panel (string-constant input-syntax)
(lambda (p)
(make-object check-box%
(string-constant case-sensitive-label)
p void)))]
[debugging
(make-panel
(string-constant dynamic-properties)
(lambda (p)
(instantiate radio-box% ()
(label #f)
(choices
`(,(string-constant no-debugging-or-profiling)
,(string-constant debugging)
,(string-constant debugging-and-profiling)))
(parent p)
(callback void))))]
[output
(make-panel (string-constant output-style-label)
"always current-print")])
(case-lambda
[()
(drscheme:language:make-simple-settings
(send input-sensitive? get-value)
'current-print 'mixed-fraction-e #f #t
(case (send debugging get-selection)
[(0) 'none]
[(1) 'debug]
[(2) 'debug/profile]))]
[(settings)
(send input-sensitive? set-value
(drscheme:language:simple-settings-case-sensitive
settings))
(send debugging set-selection
(case (drscheme:language:simple-settings-annotations
settings)
[(none) 0]
[(debug) 1]
[(debug/profile) 2]))])))
(define/override (render-value/format value settings port port-write)
(parameterize ([current-output-port port]
[current-inspector (make-inspector)])
((current-print) value)))
(super-instantiate ())))
(define (add-swindle-language name module entry-name num one-line url)
(drscheme:language-configuration:add-language
(make-object
((drscheme:language:get-default-mixin)
(swindle-language `(lib ,(string-append module ".ss") "swindle")
name entry-name num one-line url)))))
(define phase1 void)
(define (phase2)
(for-each (lambda (args)
(apply add-swindle-language `(,@args #f)))
'(("Swindle" "swindle" "Full Swindle" 0
"Full Swindle extensions")
("Swindle w/o CLOS" "turbo" "Swindle without CLOS" 1
"Swindle without the object system")
("Swindle Syntax" "base" "Basic syntax only" 2
"Basic Swindle syntax: keyword-arguments etc")
("HTML Swindle" "html" "HTML Swindle" 3
"Swindle's HTML extension")))
(parameterize ([current-directory (collection-path "swindle")])
(define counter 100)
(define (do-customize file)
(when (regexp-match? #rx"\\.ss$" file)
(with-input-from-file file
(lambda ()
(let ([l (read-line)])
(when (regexp-match? #rx"^;+ *CustomSwindle *$" l)
(let ([file (regexp-replace #rx"\\.ss$" file "")]
[name #f] [dname #f] [one-line #f] [url #f])
(let loop ([l (read-line)])
(cond
[(regexp-match #rx"^;+ *([A-Z][A-Za-z]*): *(.*)$" l)
=> (lambda (m)
(let ([sym (string->symbol (cadr m))]
[val (caddr m)])
(case sym
[(|Name|) (set! name val)]
[(|DialogName|) (set! dname val)]
[(|OneLine|) (set! one-line val)]
[(|URL|) (set! url val)])
(loop (read-line))))]))
(unless name (set! name file))
(unless dname (set! dname name))
(unless one-line
(set! one-line
(string-append "Customized Swindle: " name)))
(set! counter (add1 counter))
(add-swindle-language
name file dname counter one-line url))))))))
(for-each do-customize
(sort (map path->string (directory-list)) string<?))))
)))
;; Add the Swindle languages to DrScheme
#lang mzscheme
(require mzlib/unit
drscheme/tool
mzlib/class
mzlib/list
mred/mred
net/sendurl
string-constants/string-constant)
(provide tool@)
(define tool@
(unit (import drscheme:tool^) (export drscheme:tool-exports^)
;; Swindle languages
(define (swindle-language module* name* entry-name* num* one-line* url*)
(class (drscheme:language:module-based-language->language-mixin
(drscheme:language:simple-module-based-language->module-based-language-mixin
(class* object%
(drscheme:language:simple-module-based-language<%>)
(define/public (get-language-numbers) `(-1000 2000 ,num*))
(define/public (get-language-position)
(list (string-constant legacy-languages)
"Swindle" entry-name*))
(define/public (get-module) module*)
(define/public (get-one-line-summary) one-line*)
(define/public (get-language-url) url*)
(define/public (get-reader)
(lambda (src port)
(let ([v (read-syntax src port)])
(if (eof-object? v)
v
(namespace-syntax-introduce v)))))
(super-instantiate ()))))
(define/override (use-namespace-require/copy?) #t)
(define/override (default-settings)
(drscheme:language:make-simple-settings
#t 'current-print 'mixed-fraction-e #f #t 'debug))
(define/override (get-language-name) name*)
(define/override (config-panel parent)
(let* ([make-panel
(lambda (msg contents)
(make-object message% msg parent)
(let ([p (instantiate vertical-panel% ()
(parent parent)
(style '(border))
(alignment '(left center)))])
(if (string? contents)
(make-object message% contents p)
(contents p))))]
[title-panel
(instantiate horizontal-panel% ()
(parent parent)
(alignment '(center center)))]
[title-pic
(make-object message%
(make-object bitmap%
(build-path (collection-path "swindle")
"swindle-logo.png"))
title-panel)]
[title (let ([p (instantiate vertical-panel% ()
(parent title-panel)
(alignment '(left center)))])
(make-object message% (format "Swindle") p)
(make-object message% (format "Setup") p)
p)]
[input-sensitive?
(make-panel (string-constant input-syntax)
(lambda (p)
(make-object check-box%
(string-constant case-sensitive-label)
p void)))]
[debugging
(make-panel
(string-constant dynamic-properties)
(lambda (p)
(instantiate radio-box% ()
(label #f)
(choices
`(,(string-constant no-debugging-or-profiling)
,(string-constant debugging)
,(string-constant debugging-and-profiling)))
(parent p)
(callback void))))]
[output
(make-panel (string-constant output-style-label)
"always current-print")])
(case-lambda
[()
(drscheme:language:make-simple-settings
(send input-sensitive? get-value)
'current-print 'mixed-fraction-e #f #t
(case (send debugging get-selection)
[(0) 'none]
[(1) 'debug]
[(2) 'debug/profile]))]
[(settings)
(send input-sensitive? set-value
(drscheme:language:simple-settings-case-sensitive
settings))
(send debugging set-selection
(case (drscheme:language:simple-settings-annotations
settings)
[(none) 0]
[(debug) 1]
[(debug/profile) 2]))])))
(define/override (render-value/format value settings port port-write)
(parameterize ([current-output-port port]
[current-inspector (make-inspector)])
((current-print) value)))
(super-instantiate ())))
(define (add-swindle-language name module entry-name num one-line url)
(drscheme:language-configuration:add-language
(make-object
((drscheme:language:get-default-mixin)
(swindle-language `(lib ,(string-append module ".ss") "swindle")
name entry-name num one-line url)))))
(define phase1 void)
(define (phase2)
(for-each (lambda (args) (apply add-swindle-language `(,@args #f)))
'(("Swindle" "swindle" "Full Swindle" 0
"Full Swindle extensions")
("Swindle w/o CLOS" "turbo" "Swindle without CLOS" 1
"Swindle without the object system")
("Swindle Syntax" "base" "Basic syntax only" 2
"Basic Swindle syntax: keyword-arguments etc")
("HTML Swindle" "html" "HTML Swindle" 3
"Swindle's HTML extension")))
(parameterize ([current-directory (collection-path "swindle")])
(define counter 100)
(define (do-customize file)
(when (regexp-match? #rx"\\.ss$" file)
(with-input-from-file file
(lambda ()
(let ([l (read-line)])
(when (regexp-match? #rx"^;+ *CustomSwindle *$" l)
(let ([file (regexp-replace #rx"\\.ss$" file "")]
[name #f] [dname #f] [one-line #f] [url #f])
(let loop ([l (read-line)])
(cond
[(regexp-match #rx"^;+ *([A-Z][A-Za-z]*): *(.*)$" l)
=> (lambda (m)
(let ([sym (string->symbol (cadr m))]
[val (caddr m)])
(case sym
[(|Name|) (set! name val)]
[(|DialogName|) (set! dname val)]
[(|OneLine|) (set! one-line val)]
[(|URL|) (set! url val)])
(loop (read-line))))]))
(unless name (set! name file))
(unless dname (set! dname name))
(unless one-line
(set! one-line
(string-append "Customized Swindle: " name)))
(set! counter (add1 counter))
(add-swindle-language
name file dname counter one-line url))))))))
(for-each do-customize
(sort (map path->string (directory-list)) string<?))))
))

54
collects/swindle/turbo.ss
View File

@ -4,41 +4,39 @@
;;> new language module. Use this module to get most of Swindle's
;;> functionality which is unrelated to the object system.
(module turbo (lib "base.ss" "swindle")
(require (lib "setf.ss" "swindle")
(lib "misc.ss" "swindle"))
(provide (all-from-except (lib "base.ss" "swindle")
set! set!-values #%module-begin)
(rename module-begin~ #%module-begin)
(all-from-except (lib "setf.ss" "swindle") setf! psetf!)
#lang s-exp swindle/base
(require swindle/setf swindle/misc)
(provide (all-from-except swindle/base set! set!-values #%module-begin)
(rename module-begin~ #%module-begin)
(all-from-except swindle/setf setf! psetf!)
;;>> (set! place value ...) [*syntax*]
;;>> (pset! place value ...) [*syntax*]
;;>> (set!-values (place ...) expr) [*syntax*]
;;> This module renames `setf!', `psetf!', and `setf!-values' from the
;;> `setf' module as `set!', `pset!' and `set!-values' so the built-in
;;> `set!' and `set!-values' syntaxes are overridden.
(rename setf! set!) (rename psetf! pset!)
(rename setf!-values set!-values)
(all-from (lib "misc.ss" "swindle")))
(rename setf! set!) (rename psetf! pset!)
(rename setf!-values set!-values)
(all-from swindle/misc))
;;>> #%module-begin
;;> `turbo' is a language module -- it redefines `#%module-begin' to load
;;> itself for syntax definitions.
(defsyntax (module-begin~ stx)
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
(if (pair? e)
(datum->syntax-object
(quote-syntax here)
(list* (quote-syntax #%plain-module-begin)
(datum->syntax-object stx
(list (quote-syntax require-for-syntax)
'(lib "turbo.ss" "swindle")))
(cdr e))
stx)
(raise-syntax-error #f "bad syntax" stx)))
;; This doesn't work anymore (from 203.4)
;; (syntax-rules ()
;; [(_ . body)
;; (#%plain-module-begin
;; (require-for-syntax (lib "turbo.ss" "swindle")) . body)])
)
(defsyntax (module-begin~ stx)
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
(if (pair? e)
(datum->syntax-object
(quote-syntax here)
(list* (quote-syntax #%plain-module-begin)
(datum->syntax-object stx
(list (quote-syntax require-for-syntax)
'(lib "turbo.ss" "swindle")))
(cdr e))
stx)
(raise-syntax-error #f "bad syntax" stx)))
;; This doesn't work anymore (from 203.4)
;; (syntax-rules ()
;; [(_ . body)
;; (#%plain-module-begin
;; (require-for-syntax (lib "turbo.ss" "swindle")) . body)])
)