more v4-isms
svn: r8523
This commit is contained in:
parent
d113956877
commit
5a08a34f73
|
@ -3,7 +3,7 @@
|
||||||
;;> The `base' module defines some basic low-level syntactic extensions to
|
;;> The `base' module defines some basic low-level syntactic extensions to
|
||||||
;;> MzScheme. It can be used by itself to get these extensions.
|
;;> MzScheme. It can be used by itself to get these extensions.
|
||||||
|
|
||||||
(module base mzscheme
|
#lang mzscheme
|
||||||
|
|
||||||
(provide (all-from-except mzscheme
|
(provide (all-from-except mzscheme
|
||||||
#%module-begin #%top #%app define let let* letrec lambda
|
#%module-begin #%top #%app define let let* letrec lambda
|
||||||
|
@ -19,16 +19,15 @@
|
||||||
(datum->syntax-object
|
(datum->syntax-object
|
||||||
(quote-syntax here)
|
(quote-syntax here)
|
||||||
(list* (quote-syntax #%plain-module-begin)
|
(list* (quote-syntax #%plain-module-begin)
|
||||||
(datum->syntax-object stx
|
(datum->syntax-object
|
||||||
(list (quote-syntax require-for-syntax)
|
stx (list (quote-syntax require-for-syntax) 'swindle/base))
|
||||||
'(lib "base.ss" "swindle")))
|
|
||||||
(cdr e))
|
(cdr e))
|
||||||
stx)
|
stx)
|
||||||
(raise-syntax-error #f "bad syntax" stx)))
|
(raise-syntax-error #f "bad syntax" stx)))
|
||||||
;; This doesn't work anymore (from 203.4)
|
;; This doesn't work anymore (from 203.4)
|
||||||
;; (syntax-rules ()
|
;; (syntax-rules ()
|
||||||
;; [(_ . body) (#%plain-module-begin
|
;; [(_ . body) (#%plain-module-begin
|
||||||
;; (require-for-syntax (lib "base.ss" "swindle")) . body)])
|
;; (require-for-syntax swindle/base) . body)])
|
||||||
)
|
)
|
||||||
|
|
||||||
;;>> (#%top . id)
|
;;>> (#%top . id)
|
||||||
|
@ -593,5 +592,3 @@
|
||||||
[else
|
[else
|
||||||
(loop (cddr as)
|
(loop (cddr as)
|
||||||
(if (memq (car as) outs) r (list* (cadr as) (car as) r)))])))
|
(if (memq (car as) outs) r (list* (cadr as) (car as) r)))])))
|
||||||
|
|
||||||
)
|
|
||||||
|
|
|
@ -3,10 +3,10 @@
|
||||||
;;> This module contains only syntax definitions, which makes Swindle closer
|
;;> This module contains only syntax definitions, which makes Swindle closer
|
||||||
;;> to CLOS -- making the object system much more convenient to use.
|
;;> 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"))
|
(require swindle/tiny-clos)
|
||||||
(provide (all-from (lib "tiny-clos.ss" "swindle")))
|
(provide (all-from swindle/tiny-clos))
|
||||||
|
|
||||||
;;; ---------------------------------------------------------------------------
|
;;; ---------------------------------------------------------------------------
|
||||||
;;; General helpers
|
;;; General helpers
|
||||||
|
@ -730,5 +730,3 @@
|
||||||
(provide defgeneric*) (make-provide-syntax defgeneric defgeneric*)
|
(provide defgeneric*) (make-provide-syntax defgeneric defgeneric*)
|
||||||
(provide defclass*) (make-provide-syntax defclass defclass*)
|
(provide defclass*) (make-provide-syntax defclass defclass*)
|
||||||
(provide defentityclass*) (make-provide-syntax defentityclass defentityclass*)
|
(provide defentityclass*) (make-provide-syntax defentityclass defentityclass*)
|
||||||
|
|
||||||
)
|
|
||||||
|
|
|
@ -24,32 +24,33 @@
|
||||||
;;; not things that can be made into a module -- a teachpack is better for
|
;;; not things that can be made into a module -- a teachpack is better for
|
||||||
;;; those.
|
;;; those.
|
||||||
|
|
||||||
(module custom (lib "swindle.ss" "swindle")
|
#lang 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))))
|
|
||||||
|
|
||||||
;;; 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
|
;;; syntax get indented correctly. For this, create the default preference
|
||||||
;;; file "plt/collects/defaults/plt-prefs.ss", and in it you can put any
|
;;; 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
|
;;; specific preferences you want as the defaults for people who run the system
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
(module extra (lib "turbo.ss" "swindle")
|
#lang s-exp swindle/turbo
|
||||||
|
|
||||||
;;> This module defines some additional useful functionality which requires
|
;;> This module defines some additional useful functionality which requires
|
||||||
;;> Swindle.
|
;;> Swindle.
|
||||||
|
|
||||||
(require (lib "clos.ss" "swindle"))
|
(require swindle/clos)
|
||||||
|
|
||||||
;;; ---------------------------------------------------------------------------
|
;;; ---------------------------------------------------------------------------
|
||||||
;;; A convenient `defstruct'
|
;;; A convenient `defstruct'
|
||||||
|
@ -969,5 +969,3 @@
|
||||||
(ui-question str args "Ok/Cancel" 'ok '(ok-cancel) #\o #\c))
|
(ui-question str args "Ok/Cancel" 'ok '(ok-cancel) #\o #\c))
|
||||||
(define* (yes/no? str . args)
|
(define* (yes/no? str . args)
|
||||||
(ui-question str args "Yes/No" 'yes '(yes-no) #\y #\n))
|
(ui-question str args "Yes/No" 'yes '(yes-no) #\y #\n))
|
||||||
|
|
||||||
)
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -3,14 +3,10 @@
|
||||||
(module info setup/infotab
|
(module info setup/infotab
|
||||||
;;
|
;;
|
||||||
(define name "Swindle")
|
(define name "Swindle")
|
||||||
(define blurb
|
(define blurb '("Swindle extensions for MzScheme -- CLOS and more."))
|
||||||
'("Swindle extensions for MzScheme -- CLOS and more."))
|
(define help-desk-message "Mz/Mr: (require (lib \"swindle.ss\" \"swindle\"))")
|
||||||
(define help-desk-message
|
|
||||||
"Mz/Mr: (require (lib \"swindle.ss\" \"swindle\"))")
|
|
||||||
(define mzscheme-launcher-names '("swindle"))
|
(define mzscheme-launcher-names '("swindle"))
|
||||||
(define mzscheme-launcher-flags
|
(define mzscheme-launcher-flags '(("-li" "swindle")))
|
||||||
'(("-me"
|
|
||||||
"(namespace-require/copy (quote (lib \"swindle.ss\" \"swindle\")))")))
|
|
||||||
;;
|
;;
|
||||||
;; This simple interface is not enough, use tool.ss instead
|
;; This simple interface is not enough, use tool.ss instead
|
||||||
;; (define drscheme-language-modules
|
;; (define drscheme-language-modules
|
||||||
|
|
2
collects/swindle/lang/reader.ss
Normal file
2
collects/swindle/lang/reader.ss
Normal file
|
@ -0,0 +1,2 @@
|
||||||
|
#lang s-exp syntax/module-reader
|
||||||
|
swindle
|
17
collects/swindle/main.ss
Normal file
17
collects/swindle/main.ss
Normal 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)
|
|
@ -3,14 +3,11 @@
|
||||||
;;> A lot of miscellaneous functionality that is needed for Swindle, or
|
;;> A lot of miscellaneous functionality that is needed for Swindle, or
|
||||||
;;> useful by itself.
|
;;> useful by itself.
|
||||||
|
|
||||||
(module misc (lib "base.ss" "swindle")
|
#lang s-exp swindle/base
|
||||||
|
|
||||||
(require (lib "list.ss"))
|
(require mzlib/list) (provide (all-from mzlib/list))
|
||||||
(provide (all-from (lib "list.ss")))
|
(require mzlib/etc) (provide (all-from mzlib/etc))
|
||||||
(require (lib "etc.ss"))
|
(require mzlib/string) (provide (all-from mzlib/string))
|
||||||
(provide (all-from (lib "etc.ss")))
|
|
||||||
(require (all-except (lib "string.ss")))
|
|
||||||
(provide (all-from (lib "string.ss")))
|
|
||||||
|
|
||||||
;; ----------------------------------------------------------------------------
|
;; ----------------------------------------------------------------------------
|
||||||
;;>>... Convenient syntax definitions
|
;;>>... Convenient syntax definitions
|
||||||
|
@ -157,7 +154,7 @@
|
||||||
;;> with `defsubst' above).
|
;;> with `defsubst' above).
|
||||||
;;> * A `letmacro' form for local macros is provided.
|
;;> * 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)
|
(provide defmacro letmacro)
|
||||||
(define-syntaxes (defmacro letmacro)
|
(define-syntaxes (defmacro letmacro)
|
||||||
(let ()
|
(let ()
|
||||||
|
@ -1900,5 +1897,3 @@
|
||||||
[(_ str clause ...)
|
[(_ str clause ...)
|
||||||
#`(let ([s str])
|
#`(let ([s str])
|
||||||
(cond #,@(map do-clause (syntax->list #'(clause ...)))))]))
|
(cond #,@(map do-clause (syntax->list #'(clause ...)))))]))
|
||||||
|
|
||||||
)
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
(module patterns mzscheme
|
#lang mzscheme
|
||||||
|
|
||||||
(provide (all-from-except mzscheme
|
(provide (all-from-except mzscheme
|
||||||
define-values
|
define-values
|
||||||
|
@ -263,5 +263,3 @@
|
||||||
;; (require foo)
|
;; (require foo)
|
||||||
;; (define a (make-point 1 2))
|
;; (define a (make-point 1 2))
|
||||||
;; (let ([(make-point x y) a]) (+ x y))
|
;; (let ([(make-point x y) a]) (+ x y))
|
||||||
|
|
||||||
)
|
|
||||||
|
|
|
@ -8,7 +8,7 @@
|
||||||
;;> this just defines the basic functionality, the `misc' module defines
|
;;> this just defines the basic functionality, the `misc' module defines
|
||||||
;;> many common setters.
|
;;> many common setters.
|
||||||
|
|
||||||
(module setf mzscheme
|
#lang mzscheme
|
||||||
|
|
||||||
;;>> (setf! place value ...)
|
;;>> (setf! place value ...)
|
||||||
;;> Expand `(setf! (foo ...) v)' to `(set-foo! ... v)'. The generated
|
;;> Expand `(setf! (foo ...) v)' to `(set-foo! ... v)'. The generated
|
||||||
|
@ -274,5 +274,3 @@
|
||||||
(lambda (p)
|
(lambda (p)
|
||||||
#`(let ([p1 #,p])
|
#`(let ([p1 #,p])
|
||||||
(begin0 (car p1) (setf! #,p (cdr p1))))))])))))
|
(begin0 (car p1) (setf! #,p (cdr p1))))))])))))
|
||||||
|
|
||||||
)
|
|
||||||
|
|
|
@ -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")
|
|
||||||
)
|
|
|
@ -30,7 +30,7 @@
|
||||||
;;; DAMAGES.
|
;;; 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.
|
;;; A very simple CLOS-like language, embedded in Scheme, with a simple MOP.
|
||||||
;;; The features of the default base language are:
|
;;; 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
|
;;; 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
|
;;; interesting, we have to muck around for a bit first. First, we need to
|
||||||
;;; load the support library. [-- replaced with a module.]
|
;;; load the support library. [-- replaced with a module.]
|
||||||
(require (lib "misc.ss" "swindle"))
|
(require swindle/misc)
|
||||||
|
|
||||||
;; This is a convenient function for raising exceptions
|
;; This is a convenient function for raising exceptions
|
||||||
(define (raise* exn-maker fmt . args)
|
(define (raise* exn-maker fmt . args)
|
||||||
|
@ -2336,5 +2336,3 @@
|
||||||
;;> compute-methods
|
;;> compute-methods
|
||||||
;;> compute-method-more-specific?
|
;;> compute-method-more-specific?
|
||||||
;;> compute-apply-methods
|
;;> compute-apply-methods
|
||||||
|
|
||||||
)
|
|
||||||
|
|
|
@ -1,162 +1,163 @@
|
||||||
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
|
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
|
||||||
|
|
||||||
;; This allows adding a Swindle icon on startup.
|
;; Add the Swindle languages to DrScheme
|
||||||
(module tool mzscheme
|
#lang mzscheme
|
||||||
(require (lib "unit.ss")
|
|
||||||
(lib "tool.ss" "drscheme")
|
(require mzlib/unit
|
||||||
(lib "class.ss")
|
drscheme/tool
|
||||||
(lib "list.ss")
|
mzlib/class
|
||||||
(lib "mred.ss" "mred")
|
mzlib/list
|
||||||
(lib "sendurl.ss" "net")
|
mred/mred
|
||||||
(lib "string-constant.ss" "string-constants"))
|
net/sendurl
|
||||||
(provide tool@)
|
string-constants/string-constant)
|
||||||
(define tool@
|
(provide tool@)
|
||||||
(unit (import drscheme:tool^) (export drscheme:tool-exports^)
|
|
||||||
;; Swindle languages
|
(define tool@
|
||||||
(define (swindle-language module* name* entry-name* num* one-line* url*)
|
(unit (import drscheme:tool^) (export drscheme:tool-exports^)
|
||||||
(class (drscheme:language:module-based-language->language-mixin
|
;; Swindle languages
|
||||||
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
(define (swindle-language module* name* entry-name* num* one-line* url*)
|
||||||
(class* object%
|
(class (drscheme:language:module-based-language->language-mixin
|
||||||
(drscheme:language:simple-module-based-language<%>)
|
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
||||||
(define/public (get-language-numbers) `(-1000 2000 ,num*))
|
(class* object%
|
||||||
(define/public (get-language-position)
|
(drscheme:language:simple-module-based-language<%>)
|
||||||
(list (string-constant legacy-languages)
|
(define/public (get-language-numbers) `(-1000 2000 ,num*))
|
||||||
"Swindle" entry-name*))
|
(define/public (get-language-position)
|
||||||
(define/public (get-module) module*)
|
(list (string-constant legacy-languages)
|
||||||
(define/public (get-one-line-summary) one-line*)
|
"Swindle" entry-name*))
|
||||||
(define/public (get-language-url) url*)
|
(define/public (get-module) module*)
|
||||||
(define/public (get-reader)
|
(define/public (get-one-line-summary) one-line*)
|
||||||
(lambda (src port)
|
(define/public (get-language-url) url*)
|
||||||
(let ([v (read-syntax src port)])
|
(define/public (get-reader)
|
||||||
(if (eof-object? v)
|
(lambda (src port)
|
||||||
v
|
(let ([v (read-syntax src port)])
|
||||||
(namespace-syntax-introduce v)))))
|
(if (eof-object? v)
|
||||||
(super-instantiate ()))))
|
v
|
||||||
(define/override (use-namespace-require/copy?) #t)
|
(namespace-syntax-introduce v)))))
|
||||||
(define/override (default-settings)
|
(super-instantiate ()))))
|
||||||
(drscheme:language:make-simple-settings
|
(define/override (use-namespace-require/copy?) #t)
|
||||||
#t 'current-print 'mixed-fraction-e #f #t 'debug))
|
(define/override (default-settings)
|
||||||
(define/override (get-language-name) name*)
|
(drscheme:language:make-simple-settings
|
||||||
(define/override (config-panel parent)
|
#t 'current-print 'mixed-fraction-e #f #t 'debug))
|
||||||
(let* ([make-panel
|
(define/override (get-language-name) name*)
|
||||||
(lambda (msg contents)
|
(define/override (config-panel parent)
|
||||||
(make-object message% msg parent)
|
(let* ([make-panel
|
||||||
(let ([p (instantiate vertical-panel% ()
|
(lambda (msg contents)
|
||||||
(parent parent)
|
(make-object message% msg parent)
|
||||||
(style '(border))
|
(let ([p (instantiate vertical-panel% ()
|
||||||
(alignment '(left center)))])
|
(parent parent)
|
||||||
(if (string? contents)
|
(style '(border))
|
||||||
(make-object message% contents p)
|
(alignment '(left center)))])
|
||||||
(contents p))))]
|
(if (string? contents)
|
||||||
[title-panel
|
(make-object message% contents p)
|
||||||
(instantiate horizontal-panel% ()
|
(contents p))))]
|
||||||
(parent parent)
|
[title-panel
|
||||||
(alignment '(center center)))]
|
(instantiate horizontal-panel% ()
|
||||||
[title-pic
|
(parent parent)
|
||||||
(make-object message%
|
(alignment '(center center)))]
|
||||||
(make-object bitmap%
|
[title-pic
|
||||||
(build-path (collection-path "swindle")
|
(make-object message%
|
||||||
"swindle-logo.png"))
|
(make-object bitmap%
|
||||||
title-panel)]
|
(build-path (collection-path "swindle")
|
||||||
[title (let ([p (instantiate vertical-panel% ()
|
"swindle-logo.png"))
|
||||||
(parent title-panel)
|
title-panel)]
|
||||||
(alignment '(left center)))])
|
[title (let ([p (instantiate vertical-panel% ()
|
||||||
(make-object message% (format "Swindle") p)
|
(parent title-panel)
|
||||||
(make-object message% (format "Setup") p)
|
(alignment '(left center)))])
|
||||||
p)]
|
(make-object message% (format "Swindle") p)
|
||||||
[input-sensitive?
|
(make-object message% (format "Setup") p)
|
||||||
(make-panel (string-constant input-syntax)
|
p)]
|
||||||
(lambda (p)
|
[input-sensitive?
|
||||||
(make-object check-box%
|
(make-panel (string-constant input-syntax)
|
||||||
(string-constant case-sensitive-label)
|
(lambda (p)
|
||||||
p void)))]
|
(make-object check-box%
|
||||||
[debugging
|
(string-constant case-sensitive-label)
|
||||||
(make-panel
|
p void)))]
|
||||||
(string-constant dynamic-properties)
|
[debugging
|
||||||
(lambda (p)
|
(make-panel
|
||||||
(instantiate radio-box% ()
|
(string-constant dynamic-properties)
|
||||||
(label #f)
|
(lambda (p)
|
||||||
(choices
|
(instantiate radio-box% ()
|
||||||
`(,(string-constant no-debugging-or-profiling)
|
(label #f)
|
||||||
,(string-constant debugging)
|
(choices
|
||||||
,(string-constant debugging-and-profiling)))
|
`(,(string-constant no-debugging-or-profiling)
|
||||||
(parent p)
|
,(string-constant debugging)
|
||||||
(callback void))))]
|
,(string-constant debugging-and-profiling)))
|
||||||
[output
|
(parent p)
|
||||||
(make-panel (string-constant output-style-label)
|
(callback void))))]
|
||||||
"always current-print")])
|
[output
|
||||||
(case-lambda
|
(make-panel (string-constant output-style-label)
|
||||||
[()
|
"always current-print")])
|
||||||
(drscheme:language:make-simple-settings
|
(case-lambda
|
||||||
(send input-sensitive? get-value)
|
[()
|
||||||
'current-print 'mixed-fraction-e #f #t
|
(drscheme:language:make-simple-settings
|
||||||
(case (send debugging get-selection)
|
(send input-sensitive? get-value)
|
||||||
[(0) 'none]
|
'current-print 'mixed-fraction-e #f #t
|
||||||
[(1) 'debug]
|
(case (send debugging get-selection)
|
||||||
[(2) 'debug/profile]))]
|
[(0) 'none]
|
||||||
[(settings)
|
[(1) 'debug]
|
||||||
(send input-sensitive? set-value
|
[(2) 'debug/profile]))]
|
||||||
(drscheme:language:simple-settings-case-sensitive
|
[(settings)
|
||||||
settings))
|
(send input-sensitive? set-value
|
||||||
(send debugging set-selection
|
(drscheme:language:simple-settings-case-sensitive
|
||||||
(case (drscheme:language:simple-settings-annotations
|
settings))
|
||||||
settings)
|
(send debugging set-selection
|
||||||
[(none) 0]
|
(case (drscheme:language:simple-settings-annotations
|
||||||
[(debug) 1]
|
settings)
|
||||||
[(debug/profile) 2]))])))
|
[(none) 0]
|
||||||
(define/override (render-value/format value settings port port-write)
|
[(debug) 1]
|
||||||
(parameterize ([current-output-port port]
|
[(debug/profile) 2]))])))
|
||||||
[current-inspector (make-inspector)])
|
(define/override (render-value/format value settings port port-write)
|
||||||
((current-print) value)))
|
(parameterize ([current-output-port port]
|
||||||
(super-instantiate ())))
|
[current-inspector (make-inspector)])
|
||||||
(define (add-swindle-language name module entry-name num one-line url)
|
((current-print) value)))
|
||||||
(drscheme:language-configuration:add-language
|
(super-instantiate ())))
|
||||||
(make-object
|
(define (add-swindle-language name module entry-name num one-line url)
|
||||||
((drscheme:language:get-default-mixin)
|
(drscheme:language-configuration:add-language
|
||||||
(swindle-language `(lib ,(string-append module ".ss") "swindle")
|
(make-object
|
||||||
name entry-name num one-line url)))))
|
((drscheme:language:get-default-mixin)
|
||||||
(define phase1 void)
|
(swindle-language `(lib ,(string-append module ".ss") "swindle")
|
||||||
(define (phase2)
|
name entry-name num one-line url)))))
|
||||||
(for-each (lambda (args)
|
(define phase1 void)
|
||||||
(apply add-swindle-language `(,@args #f)))
|
(define (phase2)
|
||||||
'(("Swindle" "swindle" "Full Swindle" 0
|
(for-each (lambda (args) (apply add-swindle-language `(,@args #f)))
|
||||||
"Full Swindle extensions")
|
'(("Swindle" "swindle" "Full Swindle" 0
|
||||||
("Swindle w/o CLOS" "turbo" "Swindle without CLOS" 1
|
"Full Swindle extensions")
|
||||||
"Swindle without the object system")
|
("Swindle w/o CLOS" "turbo" "Swindle without CLOS" 1
|
||||||
("Swindle Syntax" "base" "Basic syntax only" 2
|
"Swindle without the object system")
|
||||||
"Basic Swindle syntax: keyword-arguments etc")
|
("Swindle Syntax" "base" "Basic syntax only" 2
|
||||||
("HTML Swindle" "html" "HTML Swindle" 3
|
"Basic Swindle syntax: keyword-arguments etc")
|
||||||
"Swindle's HTML extension")))
|
("HTML Swindle" "html" "HTML Swindle" 3
|
||||||
(parameterize ([current-directory (collection-path "swindle")])
|
"Swindle's HTML extension")))
|
||||||
(define counter 100)
|
(parameterize ([current-directory (collection-path "swindle")])
|
||||||
(define (do-customize file)
|
(define counter 100)
|
||||||
(when (regexp-match? #rx"\\.ss$" file)
|
(define (do-customize file)
|
||||||
(with-input-from-file file
|
(when (regexp-match? #rx"\\.ss$" file)
|
||||||
(lambda ()
|
(with-input-from-file file
|
||||||
(let ([l (read-line)])
|
(lambda ()
|
||||||
(when (regexp-match? #rx"^;+ *CustomSwindle *$" l)
|
(let ([l (read-line)])
|
||||||
(let ([file (regexp-replace #rx"\\.ss$" file "")]
|
(when (regexp-match? #rx"^;+ *CustomSwindle *$" l)
|
||||||
[name #f] [dname #f] [one-line #f] [url #f])
|
(let ([file (regexp-replace #rx"\\.ss$" file "")]
|
||||||
(let loop ([l (read-line)])
|
[name #f] [dname #f] [one-line #f] [url #f])
|
||||||
(cond
|
(let loop ([l (read-line)])
|
||||||
[(regexp-match #rx"^;+ *([A-Z][A-Za-z]*): *(.*)$" l)
|
(cond
|
||||||
=> (lambda (m)
|
[(regexp-match #rx"^;+ *([A-Z][A-Za-z]*): *(.*)$" l)
|
||||||
(let ([sym (string->symbol (cadr m))]
|
=> (lambda (m)
|
||||||
[val (caddr m)])
|
(let ([sym (string->symbol (cadr m))]
|
||||||
(case sym
|
[val (caddr m)])
|
||||||
[(|Name|) (set! name val)]
|
(case sym
|
||||||
[(|DialogName|) (set! dname val)]
|
[(|Name|) (set! name val)]
|
||||||
[(|OneLine|) (set! one-line val)]
|
[(|DialogName|) (set! dname val)]
|
||||||
[(|URL|) (set! url val)])
|
[(|OneLine|) (set! one-line val)]
|
||||||
(loop (read-line))))]))
|
[(|URL|) (set! url val)])
|
||||||
(unless name (set! name file))
|
(loop (read-line))))]))
|
||||||
(unless dname (set! dname name))
|
(unless name (set! name file))
|
||||||
(unless one-line
|
(unless dname (set! dname name))
|
||||||
(set! one-line
|
(unless one-line
|
||||||
(string-append "Customized Swindle: " name)))
|
(set! one-line
|
||||||
(set! counter (add1 counter))
|
(string-append "Customized Swindle: " name)))
|
||||||
(add-swindle-language
|
(set! counter (add1 counter))
|
||||||
name file dname counter one-line url))))))))
|
(add-swindle-language
|
||||||
(for-each do-customize
|
name file dname counter one-line url))))))))
|
||||||
(sort (map path->string (directory-list)) string<?))))
|
(for-each do-customize
|
||||||
)))
|
(sort (map path->string (directory-list)) string<?))))
|
||||||
|
))
|
||||||
|
|
|
@ -4,41 +4,39 @@
|
||||||
;;> new language module. Use this module to get most of Swindle's
|
;;> new language module. Use this module to get most of Swindle's
|
||||||
;;> functionality which is unrelated to the object system.
|
;;> functionality which is unrelated to the object system.
|
||||||
|
|
||||||
(module turbo (lib "base.ss" "swindle")
|
#lang s-exp swindle/base
|
||||||
(require (lib "setf.ss" "swindle")
|
|
||||||
(lib "misc.ss" "swindle"))
|
(require swindle/setf swindle/misc)
|
||||||
(provide (all-from-except (lib "base.ss" "swindle")
|
(provide (all-from-except swindle/base set! set!-values #%module-begin)
|
||||||
set! set!-values #%module-begin)
|
(rename module-begin~ #%module-begin)
|
||||||
(rename module-begin~ #%module-begin)
|
(all-from-except swindle/setf setf! psetf!)
|
||||||
(all-from-except (lib "setf.ss" "swindle") setf! psetf!)
|
|
||||||
;;>> (set! place value ...) [*syntax*]
|
;;>> (set! place value ...) [*syntax*]
|
||||||
;;>> (pset! place value ...) [*syntax*]
|
;;>> (pset! place value ...) [*syntax*]
|
||||||
;;>> (set!-values (place ...) expr) [*syntax*]
|
;;>> (set!-values (place ...) expr) [*syntax*]
|
||||||
;;> This module renames `setf!', `psetf!', and `setf!-values' from the
|
;;> This module renames `setf!', `psetf!', and `setf!-values' from the
|
||||||
;;> `setf' module as `set!', `pset!' and `set!-values' so the built-in
|
;;> `setf' module as `set!', `pset!' and `set!-values' so the built-in
|
||||||
;;> `set!' and `set!-values' syntaxes are overridden.
|
;;> `set!' and `set!-values' syntaxes are overridden.
|
||||||
(rename setf! set!) (rename psetf! pset!)
|
(rename setf! set!) (rename psetf! pset!)
|
||||||
(rename setf!-values set!-values)
|
(rename setf!-values set!-values)
|
||||||
(all-from (lib "misc.ss" "swindle")))
|
(all-from swindle/misc))
|
||||||
;;>> #%module-begin
|
;;>> #%module-begin
|
||||||
;;> `turbo' is a language module -- it redefines `#%module-begin' to load
|
;;> `turbo' is a language module -- it redefines `#%module-begin' to load
|
||||||
;;> itself for syntax definitions.
|
;;> itself for syntax definitions.
|
||||||
(defsyntax (module-begin~ stx)
|
(defsyntax (module-begin~ stx)
|
||||||
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
|
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
|
||||||
(if (pair? e)
|
(if (pair? e)
|
||||||
(datum->syntax-object
|
(datum->syntax-object
|
||||||
(quote-syntax here)
|
(quote-syntax here)
|
||||||
(list* (quote-syntax #%plain-module-begin)
|
(list* (quote-syntax #%plain-module-begin)
|
||||||
(datum->syntax-object stx
|
(datum->syntax-object stx
|
||||||
(list (quote-syntax require-for-syntax)
|
(list (quote-syntax require-for-syntax)
|
||||||
'(lib "turbo.ss" "swindle")))
|
'(lib "turbo.ss" "swindle")))
|
||||||
(cdr e))
|
(cdr e))
|
||||||
stx)
|
stx)
|
||||||
(raise-syntax-error #f "bad syntax" stx)))
|
(raise-syntax-error #f "bad syntax" stx)))
|
||||||
;; This doesn't work anymore (from 203.4)
|
;; This doesn't work anymore (from 203.4)
|
||||||
;; (syntax-rules ()
|
;; (syntax-rules ()
|
||||||
;; [(_ . body)
|
;; [(_ . body)
|
||||||
;; (#%plain-module-begin
|
;; (#%plain-module-begin
|
||||||
;; (require-for-syntax (lib "turbo.ss" "swindle")) . body)])
|
;; (require-for-syntax (lib "turbo.ss" "swindle")) . body)])
|
||||||
)
|
|
||||||
)
|
)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user