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 ;;> 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)))])))
)

8
collects/swindle/clos.ss
View File

@ -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*)
)

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 ;;; 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

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 ;;> 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))
)

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 (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
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 ;;> 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 ...)))))]))
)

4
collects/swindle/patterns.ss
View File

@ -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))
)

4
collects/swindle/setf.ss
View File

@ -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))))))])))))
)

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. ;;; 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
)

321
collects/swindle/tool.ss
View File

@ -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<?))))
))

54
collects/swindle/turbo.ss
View File

@ -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)])
)
) )