├── lang └── reader.rkt ├── swindle-icon.png ├── swindle-logo.png ├── .gitignore ├── main.rkt ├── LICENSE ├── README.md ├── turbo.rkt ├── info.rkt ├── custom.rkt ├── swindle.scrbl ├── readme.txt ├── tool.rkt ├── patterns.rkt ├── setf.rkt ├── base.rkt ├── clos.rkt └── extra.rkt /lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | swindle 3 | -------------------------------------------------------------------------------- /swindle-icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/swindle/HEAD/swindle-icon.png -------------------------------------------------------------------------------- /swindle-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/racket/swindle/HEAD/swindle-logo.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Racket compiled files 2 | compiled/ 3 | 4 | # common backups, autosaves, lock files, OS meta-files 5 | *~ 6 | \#* 7 | .#* 8 | .DS_Store 9 | *.bak 10 | TAGS 11 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | ;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org) 2 | 3 | ;;> This module combines all modules to form the Swindle language module. 4 | ;;> 5 | ;;> Note that it does not re-define `#%module-begin', so the language used 6 | ;;> for transformers is still the one defined by `turbo'. 7 | 8 | #lang s-exp swindle/turbo 9 | 10 | (require swindle/clos swindle/extra) 11 | (provide (all-from swindle/turbo) 12 | (all-from swindle/clos) 13 | (all-from swindle/extra)) 14 | (current-prompt-read 15 | (let ([old-prompt-read (current-prompt-read)]) 16 | (lambda () (display "=") (flush-output) (old-prompt-read)))) 17 | (install-swindle-printer) 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This component of Racket is distributed under the under the Apache 2.0 2 | and MIT licenses. The user can choose the license under which they 3 | will be using the software. There may be other licenses within the 4 | distribution with which the user must also comply. 5 | 6 | See the files 7 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 8 | and 9 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 10 | for the full text of the licenses. 11 | 12 | This repository incorporates code from Tiny CLOS, which is copyright 13 | Xerox and released under a variant of the Xerox License. See the file 14 | tiny-clos.rkt for the full text of the license, which is similar to 15 | the MIT License. 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # swindle 2 | 3 | This the source for the Racket package: "swindle". 4 | 5 | ### Contributing 6 | 7 | Contribute to Racket by submitting a [pull request], reporting an 8 | [issue], joining the [development mailing list], or visiting the 9 | IRC or Slack channels. 10 | 11 | ### License 12 | 13 | Racket, including these packages, is free software, see [LICENSE] 14 | for more details. 15 | 16 | By making a contribution, you are agreeing that your contribution 17 | is licensed under the [Apache 2.0] license and the [MIT] license. 18 | 19 | [MIT]: https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 20 | [Apache 2.0]: https://www.apache.org/licenses/LICENSE-2.0.txt 21 | [pull request]: https://github.com/racket/swindle/pulls 22 | [issue]: https://github.com/racket/swindle/issues 23 | [development mailing list]: https://lists.racket-lang.org 24 | [LICENSE]: LICENSE 25 | -------------------------------------------------------------------------------- /turbo.rkt: -------------------------------------------------------------------------------- 1 | ;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org) 2 | 3 | ;;> This module combines the `base', `setf', and `misc', modules to create a 4 | ;;> new language module. Use this module to get most of Swindle's 5 | ;;> functionality which is unrelated to the object system. 6 | 7 | #lang s-exp swindle/base 8 | 9 | (require swindle/setf swindle/misc) 10 | (provide (all-from-except swindle/base set! set!-values #%module-begin) 11 | (rename module-begin~ #%module-begin) 12 | (all-from-except swindle/setf setf! psetf!) 13 | ;;>> (set! place value ...) [*syntax*] 14 | ;;>> (pset! place value ...) [*syntax*] 15 | ;;>> (set!-values (place ...) expr) [*syntax*] 16 | ;;> This module renames `setf!', `psetf!', and `setf!-values' from the 17 | ;;> `setf' module as `set!', `pset!' and `set!-values' so the built-in 18 | ;;> `set!' and `set!-values' syntaxes are overridden. 19 | (rename setf! set!) (rename psetf! pset!) 20 | (rename setf!-values set!-values) 21 | (all-from swindle/misc)) 22 | ;;>> #%module-begin 23 | ;;> `turbo' is a language module -- it redefines `#%module-begin' to load 24 | ;;> itself for syntax definitions. 25 | (defsyntax (module-begin~ stx) 26 | (let ([e (if (syntax? stx) (syntax-e stx) stx)]) 27 | (if (pair? e) 28 | (datum->syntax-object 29 | (quote-syntax here) 30 | (list* (quote-syntax #%plain-module-begin) 31 | (datum->syntax-object stx 32 | (list (quote-syntax require-for-syntax) 33 | 'swindle/turbo)) 34 | (cdr e)) 35 | stx) 36 | (raise-syntax-error #f "bad syntax" stx))) 37 | ;; This doesn't work anymore (from 203.4) 38 | ;; (syntax-rules () 39 | ;; [(_ . body) 40 | ;; (#%plain-module-begin 41 | ;; (require-for-syntax swindle/turbo) . body)]) 42 | ) 43 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | ;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org) 2 | #lang info 3 | 4 | (define collection "swindle") 5 | 6 | (define mzscheme-launcher-names '("swindle")) 7 | (define mzscheme-launcher-flags '(("-li" "swindle"))) 8 | 9 | (define scribblings '(("swindle.scrbl" () (language)))) 10 | 11 | ;; This simple interface is not enough, use tool.rkt instead 12 | ;; (define drscheme-language-modules 13 | ;; '(("swindle.rkt" "swindle") 14 | ;; ("turbo.rkt" "swindle") 15 | ;; ("html.rkt" "swindle"))) 16 | ;; (define drscheme-language-positions 17 | ;; '(("Swindle" "Full Swindle") 18 | ;; ("Swindle" "Swindle without CLOS") 19 | ;; ("Swindle" "HTML Swindle"))) 20 | ;; (define drscheme-language-numbers 21 | ;; '((-900 0) (-900 1) (-900 2))) 22 | ;; (define drscheme-language-one-line-summaries 23 | ;; '("Scheme with Full Swindle extensions" 24 | ;; "Scheme with Swindle without the object system" 25 | ;; "Scheme with the HTML and Swindle extensions")) 26 | ;; (define drscheme-language-urls 27 | ;; '("https://docs.racket-lang.org/swindle/" 28 | ;; "https://docs.racket-lang.org/swindle/" 29 | ;; "https://docs.racket-lang.org/swindle/")) 30 | 31 | (define tools '(("tool.rkt"))) 32 | (define tool-names '("Swindle")) 33 | (define tool-icons '(("swindle-icon.png" "swindle"))) 34 | (define tool-urls '("https://docs.racket-lang.org/swindle/")) 35 | (define deps '("scheme-lib" 36 | "base" 37 | "compatibility-lib" 38 | "drracket-plugin-lib" 39 | "gui-lib" 40 | "net-lib" 41 | "string-constants-lib")) 42 | (define build-deps '("compatibility-doc" 43 | "racket-doc" 44 | "scribble-lib")) 45 | 46 | (define pkg-desc "The implementation of the Swindle language") 47 | 48 | (define pkg-authors '(eli)) 49 | 50 | (define license 51 | ;; TODO: Update this if https://github.com/spdx/license-list-XML/pull/1346 52 | ;; concludes that the Tiny CLOS license should be assigned a different 53 | ;; license rather than Xerox. 54 | '(Xerox AND (Apache-2.0 OR MIT))) 55 | -------------------------------------------------------------------------------- /custom.rkt: -------------------------------------------------------------------------------- 1 | ;;; CustomSwindle 2 | ;;; Name: CustomSwindle 3 | ;;; DialogName: Customized Swindle 4 | ;;; OneLine: Sample Customized Swindle 5 | ;;; URL: http://www.barzilay.org/Swindle/ 6 | 7 | ;;; This file demonstrates how a customized Swindle-based language can be 8 | ;;; created. Most of these things could be done with the GUI language 9 | ;;; customizing, but (a) it will make it very verbose, (b) most syntax settings 10 | ;;; are things that beginners should not know about, (c) it will not allow 11 | ;;; things like the redefinition of `lambda' which is done below. To make a 12 | ;;; customization file, it should be some *.rkt file in this directory, that 13 | ;;; begins in the same way as above commented prefix: beginning with the magic 14 | ;;; string, and then specifying some parameters for this language. Specifying 15 | ;;; the language's name as it appears at the top of the interactions menu 16 | ;;; (defaults to the file name minus the ".rkt"), the name as it appears in the 17 | ;;; language selection dialog box (defaults to the Name), the one-line 18 | ;;; description (appears at the bottom of the language dialog), and a URL to 19 | ;;; jump to when the name in the interactions is clicked. Remember that since 20 | ;;; the language can be pretty different than Swindle, then appropriate 21 | ;;; documentation should be added too. 22 | ;;; 23 | ;;; This is a good place to add common functionality and customizations, but 24 | ;;; not things that can be made into a module -- a teachpack is better for 25 | ;;; those. 26 | 27 | #lang swindle 28 | 29 | ;; provide all swindle, minus `lambda' which is overriden to `method' 30 | (provide (all-from-except swindle lambda)) 31 | (provide (rename lambda~ lambda)) 32 | (defsubst lambda~ method) 33 | ;; some default customizations 34 | (*make-safely* #t) 35 | ;; set some syntax parameters -- must use eval! 36 | (eval #'(begin 37 | ;; simple defclass forms: 38 | (-defclass-auto-initargs- 39 | (;; auto acccessors, constructors, and predicates 40 | :auto #t 41 | ;; first two things after a slot name are type and initvalue 42 | :default-slot-options '(:type :initvalue) 43 | ;; printed representation of objects shows slot contents 44 | :printer print-object-with-slots)) 45 | ;; set the accessor names made by the above 46 | (-defclass-autoaccessors-naming- :class-slot) 47 | ;; always use an explicit generic 48 | (-defmethod-create-generics- #f) 49 | ;; use defgeneric + add-method for accessors (since defmethod now 50 | ;; wouldn't create the generic) 51 | (-defclass-accessor-mode- :defgeneric))) 52 | 53 | ;;; To make things even better, it is best to change preferences so Swindle 54 | ;;; syntax get indented correctly. For this, create the default preference 55 | ;;; file "plt/collects/defaults/plt-prefs.rkt", and in it you can put any 56 | ;;; specific preferences you want as the defaults for people who run the system 57 | ;;; for the first time (see the "Preference Files" section in the Help Desk). 58 | ;;; The two relevant settings are -- make Swindle the default language: 59 | ;;; (drscheme:205-settings 60 | ;;; (("Swindle" "Full Swindle") 61 | ;;; #6(#f current-print mixed-fraction-e #f #t debug))) 62 | ;;; And to make indentation handle Swindle forms correctly, locate the tab 63 | ;;; specifications line and add the swindle forms indentation: 64 | ;;; (framework:tabify 65 | ;;; (... stuff which is already there ... 66 | ;;; (define* define) (define-syntax* define) (defsyntax define) 67 | ;;; (defsyntax* define) (letsyntax lambda) (defsubst define) 68 | ;;; (defsubst* define) (letsubst lambda) (defmacro define) 69 | ;;; (defmacro* define) (letmacro lambda) (named-lambda lambda) 70 | ;;; (thunk lambda) (while lambda) (until lambda) (dotimes lambda) 71 | ;;; (dolist lambda) (no-errors lambda) (regexp-case lambda) 72 | ;;; (generic lambda) (defgeneric define) (method lambda) 73 | ;;; (named-method lambda) (qualified-method lambda) (defmethod define) 74 | ;;; (beforemethod lambda) (aftermethod lambda) (aroundmethod lambda) 75 | ;;; (defbeforemethod define) (defaftermethod define) 76 | ;;; (defaroundmethod define) (class lambda) (entityclass lambda) 77 | ;;; (defclass define) (defentityclass define) (defgeneric* define) 78 | ;;; (defclass* define) (defentityclass* define) (with-slots lambda) 79 | ;;; (with-accessors lambda) (matcher lambda) (match lambda) 80 | ;;; (defmatcher define) (defmatcher0 define))) 81 | -------------------------------------------------------------------------------- /swindle.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require scribble/manual) 3 | 4 | @title{Swindle} 5 | 6 | @defmodulelang[swindle] 7 | 8 | Swindle extends Racket with many additional features. The main 9 | feature that started this project is a CLOS-like object system based 10 | on Tiny-CLOS from Xerox, but there is a lot more. 11 | 12 | Some documentation is available at 13 | @link["http://barzilay.org/Swindle/"]{http://barzilay.org/Swindle/}. 14 | 15 | @; @table-of-contents[] 16 | 17 | @; ------------------------------ 18 | @section{Features} 19 | 20 | The following is a high-level description of major features provided by 21 | Swindle. For every feature, the file that provides it is specified, if 22 | only a subset of the system is needed. 23 | 24 | @itemize[ 25 | 26 | @item{Some basic syntax extensions, including lambda &-keywords, and 27 | improved @racket[define] and @racket[let] forms. (Available 28 | separately using @racket[swindle/base])} 29 | 30 | @item{Generic setters with @racket[set!], additional useful mutation 31 | forms: @racket[pset!], @racket[shift!], @racket[rotate!], and some 32 | simple ones like @racket[inc!], and @racket[push!]. (Available 33 | separately using @racket[swindle/setf], where the names 34 | @racket[setf!] and @racket[psetf!] are used to avoid changing the 35 | Racket form)} 36 | 37 | @item{Easy macro-defining macros --- simple @racket[syntax-rules] macros with 38 | @racket[defsubst], and a generic @racket[defmacro] utility, all with a local 39 | @racket[let...] form, and extended to easily create symbol macros. 40 | (@racket[swindle/misc])} 41 | 42 | @item{A @racket[collect] macro that provides very sophisticated list 43 | comprehensions and much more. (@racket[swindle/misc])} 44 | 45 | @item{An @racket[echo] mechanism which is an alternative to using 46 | format strings, and contains many useful features including a list 47 | iteration construct, and is easy to extend. 48 | (@racket[swindle/misc])} 49 | 50 | @item{A @racket[regexp-case] syntax which is similar to a 51 | @racket[case] on strings with easy access to submatches. 52 | (@racket[swindle/misc])} 53 | 54 | @item{A CLOS-like object system -- based on Tiny CLOS, but with many 55 | extensions that bring it much closer to CLOS, and heavily optimized. 56 | Some added features include singleton and struct classes, applicable 57 | stand-alone methods, method-combination, and some MOP extensions. 58 | (Available without syntax bindings in @racket[swindle/tiny-clos])} 59 | 60 | @item{Good integration with the Racket implementation: primitive 61 | values have corresponding Swindle classes, and struct types can also 62 | be used as type specializers. A Swindle class will be made when 63 | needed, and it will reflect the struct hierarchy. In addition, 64 | structs can be defined with a Swindle-line @racket[defstruct] syntax which 65 | will also make it possible to create these structs with 66 | @racket[make] using keyword arguments. (@racket[swindle/tiny-clos] 67 | and @racket[swindle/extra])} 68 | 69 | @item{Many hairy macros that make the object system much more convenient 70 | (CLOS has also a lot of macro code). Some of the macros (especially 71 | @racket[defclass]) can be customized. (@racket[swindle/clos])} 72 | 73 | @item{Useful generic functions, including @racket[print-object] which 74 | is used to display all objects. (@racket[swindle/extra])} 75 | 76 | @item{A @racket[match] mechanism with a generic-like interface. 77 | (@racket[swindle/extra])} 78 | 79 | @item{The fun @racket[amb] toy. (@racket[swindle/extra])} 80 | 81 | @item{A language that can easily create HTML, where the result is 82 | human-editable. (@racket[swindle/html])} 83 | 84 | @item{Customizable syntax: easy to add customized languages to DrRacket. 85 | (@racket[custom])} 86 | 87 | 88 | ] 89 | 90 | @; ------------------------------ 91 | @section{Libraries} 92 | 93 | Files marked with ``module'' provide a module by the same name, files 94 | marked with "language module" modify the language and should be used 95 | as an initial import for other modules. Most files (and especially 96 | all language modules) are useful by themselves, even without using the 97 | whole Swindle environment. 98 | 99 | @itemize[ 100 | 101 | @item{@racket[swindle/base] (language module) --- 102 | Basic syntax extensions, mainly Lisp-like lambda argument &-keywords.} 103 | 104 | @item{@racket[swindle/setf] (module) --- 105 | Generic setters similar to @racket[setf] in Lisp, and a few more useful 106 | macros.} 107 | 108 | @item{@racket[swindle/misc] (module) --- Lots of useful functionality 109 | bits, including everything from frequently useful Racket legacy 110 | libraries (@racketmodname[mzlib/list], @racketmodname[mzlib/etc], 111 | and @racketmodname[mzlib/string]).} 112 | 113 | @item{@racket[swindle/turbo] (language module) --- A module that 114 | packages functionality from @racket[swindle/base], 115 | @racket[swindle/setf] (overriding @racket[set!] with 116 | @racket[setf!]), and @racket[swindle/misc].} 117 | 118 | @item{@racket[swindle/tiny-clos] (module) --- 119 | The core object system, based on Tiny CLOS from Xerox, but heavily 120 | modified, optimized and extended.} 121 | 122 | @item{@racket[swindle/clos] (module) --- Convenient macro wrappers for 123 | @racket[swindle/tiny-clos].} 124 | 125 | @item{@racket[swindle/extra] (module) --- Extra functionality on top 126 | of @racket[swindle/clos].} 127 | 128 | @item{@racket[swindle/swindle] (language module) --- The main Swindle 129 | environment module: packages @racket[swindle/tiny-clos], 130 | @racket[swindle/clos], and @racket[swindle/extra] on top of 131 | @racket[swindle/turbo], and some more general definitions.} 132 | 133 | @item{@racket[swindle/info] (module) --- 134 | Compilation definitions.} 135 | 136 | @item{@racket[swindle/tool] (module) --- 137 | Setup for Swindle in DrRacket: makes some languages available in 138 | DrRacket, including custom Swindle-based languages.} 139 | 140 | @item{@racket[swindle/custom] (module) --- 141 | A sample file that demonstrates how to create a Swindle-based 142 | customized language; see the source for instructions.} 143 | 144 | @item{@racket[swindle/html] (module) --- 145 | A language for creating HTML.} 146 | 147 | ] 148 | -------------------------------------------------------------------------------- /readme.txt: -------------------------------------------------------------------------------- 1 | ====< Swindle >========================================================= 2 | 3 | This is the Swindle Reference Manual. 4 | 5 | Swindle is a collection of modules that extend Racket with many 6 | additional features. The main feature which started this project is a 7 | CLOS-like object system based on Tiny-CLOS from Xerox, but there is a 8 | lot more -- see the feature list below for a rough picture. Swindle is 9 | now part of the main Racket distribution. 10 | 11 | 12 | ====< Feature List >==================================================== 13 | 14 | The following is a high-level description of major features provided by 15 | Swindle. For every feature, the file that provides it is specified, if 16 | only a subset of the system is needed. 17 | 18 | * Some basic syntax extensions, including lambda &-keywords, and 19 | improved `define' and `let' forms. (Available separately using 20 | "base.rkt".) 21 | 22 | * Generic setters with `set!', additional useful mutation forms: 23 | `pset!', `shift!', `rotate!', and some simple ones like `inc!', and 24 | `push!'. (Available separately using "setf.rkt", where the names 25 | `setf!' and `psetf!' are used to avoid changing the Scheme form.) 26 | 27 | * Easy macro-defining macros -- simple syntax-rules macros with 28 | `defsubst', and a generic `defmacro' utility, all with a local 29 | `let...' form, and extended to easily create symbol macros. 30 | ("misc.rkt") 31 | 32 | * A `collect' macro that provides very sophisticated list comprehensions 33 | and much more. ("misc.rkt") 34 | 35 | * An `echo' mechanism which is an alternative to using format strings, 36 | and contains many useful features including a list iteration 37 | construct, and is easy to extend. ("misc.rkt") 38 | 39 | * A `regexp-case' syntax which is similar to a `case' on strings with 40 | easy access to submatches. ("misc.rkt") 41 | 42 | * A CLOS-like object system -- based on Tiny CLOS, but with many 43 | extensions that bring it much closer to CLOS, and heavily optimized. 44 | Some added features include singleton and struct classes, applicable 45 | stand-alone methods, method-combination, and some MOP extensions. 46 | (Available without syntax bindings in "tiny-clos.rkt") 47 | 48 | * Good integration with the Scheme implementation: primitive values have 49 | corresponding Swindle classes, and struct types can also be used as 50 | type specializers. A Swindle class will be made when needed, and it 51 | will reflect the struct hierarchy. In addition, structs can be 52 | defined with a Swindle-line `defstruct' syntax which will also make it 53 | possible to create these structs with `make' using keyword arguments. 54 | ("tiny-clos.rkt" and "extra.rkt") 55 | 56 | * Many hairy macros that make the object system much more convenient 57 | (CLOS has also a lot of macro code). Some of the macros (especially 58 | `defclass') can be customized. ("clos.rkt") 59 | 60 | * Useful generic functions, including `print-object' which is used to 61 | display all objects. ("extra.rkt") 62 | 63 | * A `match' mechanism with a generic-like interface. ("extra.rkt") 64 | 65 | * The fun `amb' toy. ("extra.rkt") 66 | 67 | * A language that can easily create HTML, where the result is 68 | human-editable. ("html.rkt") 69 | 70 | * Customizable syntax: easy to add customized languages to DrRacket. 71 | ("custom.rkt") 72 | 73 | 74 | ====< Reference Manual >================================================ 75 | 76 | Files marked with "module" provide a module by the same name, files 77 | marked with "language module" modify the language and should be used as 78 | an initial import for other modules. Most files (and especially all 79 | language modules) are useful by themselves, even without using the whole 80 | Swindle environment. 81 | 82 | * base.rkt (language module) 83 | Basic syntax extensions, mainly Lisp-like lambda argument &-keywords. 84 | 85 | * setf.rkt (module) 86 | Generic setters similar to `setf' in Lisp, and a few more useful 87 | macros. 88 | 89 | * misc.rkt (module) 90 | Lots of useful functionality bits, including everything from 91 | frequently useful Racket standard libraries (`list.rkt', `etc.rkt', 92 | and `string.rkt'). 93 | 94 | * turbo.rkt (language module) 95 | A module that packages functionality from `base', `setf' (overriding 96 | `set!' with `setf!'), and `misc'. 97 | 98 | * tiny-clos.rkt (module) 99 | The core object system, based on Tiny CLOS from Xerox, but heavily 100 | modified, optimized and extended. 101 | 102 | * clos.rkt (module) 103 | Convenient macro wrappers for "tiny-clos.rkt". 104 | 105 | * extra.rkt (module) 106 | Extra functionality on top of clos. 107 | 108 | * swindle.rkt (language module) 109 | The main Swindle environment module: packages `tiny-clos', `clos', and 110 | `extra' on top of `turbo', and some more general definitions. 111 | 112 | * info.rkt (module) 113 | Compilation definitions. 114 | 115 | * tool.rkt (module) 116 | Setup for Swindle in DrRacket -- makes some languages available in 117 | DrRacket, including custom Swindle-based languages. 118 | 119 | * custom.rkt (module) 120 | A sample file that demonstrates how to create a Swindle-based 121 | customized language -- see the source for instructions. 122 | 123 | * html.rkt (module) 124 | A language for creating HTML. 125 | 126 | * html-doc.txt 127 | Documentation file for "html.rkt". 128 | 129 | * doc.txt 130 | Descriptions of user-level functions, macros, generic functions and 131 | variables, in a format that help-desk can use. (Not included, an HTML 132 | manual is created instead.) 133 | 134 | 135 | ====< Copyright Notice >================================================ 136 | 137 | Copyright (C) 1998-2014 Eli Barzilay (eli@barzilay.org) 138 | 139 | Swindle, including this document, is dual-licensed under the under the 140 | Apache License, version 2.0, and the MIT license, at your option. See 141 | the files: 142 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 143 | and 144 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 145 | for the full text of the licenses. 146 | 147 | Swindle incorporates code from Tiny CLOS, which is copyright Xerox and 148 | released under a variant of the Xerox License. See the file 149 | `tiny-clos.rkt' for the full text of the license, which is similar to 150 | the MIT License. 151 | 152 | Unless required by applicable law or agreed to in writing, software 153 | distributed under these licenses is distributed on an "AS IS" BASIS, 154 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 155 | See the licenses for the specific language governing permissions and 156 | limitations under each license. 157 | 158 | ====< * >=============================================================== 159 | -------------------------------------------------------------------------------- /tool.rkt: -------------------------------------------------------------------------------- 1 | ;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org) 2 | 3 | ;; Add the Swindle languages to DrRacket 4 | #lang mzscheme 5 | 6 | (require mzlib/unit 7 | drscheme/tool 8 | mzlib/class 9 | mzlib/list 10 | mred 11 | net/sendurl 12 | string-constants) 13 | (provide tool@) 14 | 15 | (define tool@ 16 | (unit (import drscheme:tool^) (export drscheme:tool-exports^) 17 | ;; Swindle languages 18 | (define (swindle-language module* name* entry-name* num* one-line* url*) 19 | (class (drscheme:language:module-based-language->language-mixin 20 | (drscheme:language:simple-module-based-language->module-based-language-mixin 21 | (class* object% 22 | (drscheme:language:simple-module-based-language<%>) 23 | (define/public (get-language-numbers) `(-200 2000 ,num*)) 24 | (define/public (get-language-position) 25 | (list (string-constant legacy-languages) 26 | "Swindle" entry-name*)) 27 | (define/public (get-module) module*) 28 | (define/public (get-one-line-summary) one-line*) 29 | (define/public (get-language-url) url*) 30 | (define/public (get-reader) 31 | (lambda (src port) 32 | (let ([v (read-syntax src port)]) 33 | (if (eof-object? v) 34 | v 35 | (namespace-syntax-introduce v))))) 36 | (super-instantiate ())))) 37 | (define/augment (capability-value key) 38 | (cond 39 | [(eq? key 'macro-stepper:enabled) #t] 40 | [else (inner (drscheme:language:get-capability-default key) 41 | capability-value key)])) 42 | (define/override (use-namespace-require/copy?) #t) 43 | (define/override (default-settings) 44 | (drscheme:language:make-simple-settings 45 | #t 'write 'mixed-fraction-e #f #t 'debug)) 46 | (define/override (get-language-name) name*) 47 | (define/override (config-panel parent) 48 | (let* ([make-panel 49 | (lambda (msg contents) 50 | (make-object message% msg parent) 51 | (let ([p (instantiate vertical-panel% () 52 | (parent parent) 53 | (style '(border)) 54 | (alignment '(left center)))]) 55 | (if (string? contents) 56 | (make-object message% contents p) 57 | (contents p))))] 58 | [title-panel 59 | (instantiate horizontal-panel% () 60 | (parent parent) 61 | (alignment '(center center)))] 62 | [title-pic 63 | (make-object message% 64 | (make-object bitmap% 65 | (build-path (collection-path "swindle") 66 | "swindle-logo.png")) 67 | title-panel)] 68 | [title (let ([p (instantiate vertical-panel% () 69 | (parent title-panel) 70 | (alignment '(left center)))]) 71 | (make-object message% (format "Swindle") p) 72 | (make-object message% (format "Setup") p) 73 | p)] 74 | [input-sensitive? 75 | (make-panel (string-constant input-syntax) 76 | (lambda (p) 77 | (make-object check-box% 78 | (string-constant case-sensitive-label) 79 | p void)))] 80 | [debugging 81 | (make-panel 82 | (string-constant dynamic-properties) 83 | (lambda (p) 84 | (instantiate radio-box% () 85 | (label #f) 86 | (choices 87 | `(,(string-constant no-debugging-or-profiling) 88 | ,(string-constant debugging) 89 | ,(string-constant debugging-and-profiling))) 90 | (parent p) 91 | (callback void))))]) 92 | (case-lambda 93 | [() 94 | (drscheme:language:make-simple-settings 95 | (send input-sensitive? get-value) 96 | 'write 'mixed-fraction-e #f #t 97 | (case (send debugging get-selection) 98 | [(0) 'none] 99 | [(1) 'debug] 100 | [(2) 'debug/profile]))] 101 | [(settings) 102 | (send input-sensitive? set-value 103 | (drscheme:language:simple-settings-case-sensitive 104 | settings)) 105 | (send debugging set-selection 106 | (case (drscheme:language:simple-settings-annotations 107 | settings) 108 | [(none) 0] 109 | [(debug) 1] 110 | [(debug/profile) 2]))]))) 111 | (define last-port #f) 112 | (define/override (render-value/format value settings port width) 113 | (unless (eq? port last-port) 114 | (set! last-port port) 115 | ;; this is called with the value port, so copy the usual swindle 116 | ;; handlers to this port 117 | (port-write-handler 118 | port (port-write-handler (current-output-port))) 119 | (port-display-handler 120 | port (port-display-handler (current-output-port)))) 121 | ;; then use them instead of the default pretty print 122 | (write value port) 123 | (newline port)) 124 | (super-instantiate ()))) 125 | (define (add-swindle-language name module entry-name num one-line url) 126 | (drscheme:language-configuration:add-language 127 | (make-object 128 | ((drscheme:language:get-default-mixin) 129 | (swindle-language `(lib ,(string-append module ".rkt") "swindle") 130 | name entry-name num one-line url))))) 131 | (define phase1 void) 132 | (define (phase2) 133 | (for-each (lambda (args) (apply add-swindle-language `(,@args #f))) 134 | '(("Swindle" "main" "Full Swindle" 0 135 | "Full Swindle extensions") 136 | ("Swindle w/o CLOS" "turbo" "Swindle without CLOS" 1 137 | "Swindle without the object system") 138 | ("Swindle Syntax" "base" "Basic syntax only" 2 139 | "Basic Swindle syntax: keyword-arguments etc"))) 140 | (parameterize ([current-directory (collection-path "swindle")]) 141 | (define counter 100) 142 | (define (do-customize file) 143 | (when (regexp-match? #rx"\\.rkt$" file) 144 | (with-input-from-file file 145 | (lambda () 146 | (let ([l (read-line)]) 147 | (when (regexp-match? #rx"^;+ *CustomSwindle *$" l) 148 | (let ([file (regexp-replace #rx"\\.rkt$" file "")] 149 | [name #f] [dname #f] [one-line #f] [url #f]) 150 | (let loop ([l (read-line)]) 151 | (cond 152 | [(regexp-match #rx"^;+ *([A-Z][A-Za-z]*): *(.*)$" l) 153 | => (lambda (m) 154 | (let ([sym (string->symbol (cadr m))] 155 | [val (caddr m)]) 156 | (case sym 157 | [(|Name|) (set! name val)] 158 | [(|DialogName|) (set! dname val)] 159 | [(|OneLine|) (set! one-line val)] 160 | [(|URL|) (set! url val)]) 161 | (loop (read-line))))])) 162 | (unless name (set! name file)) 163 | (unless dname (set! dname name)) 164 | (unless one-line 165 | (set! one-line 166 | (string-append "Customized Swindle: " name))) 167 | (set! counter (add1 counter)) 168 | (add-swindle-language 169 | name file dname counter one-line url)))))))) 170 | (for-each do-customize 171 | (sort (map path->string (directory-list)) stringhandlers id) 40 | (and (identifier? id) 41 | (syntax-local-value 42 | (datum->syntax-object id 43 | (string->symbol 44 | (string-append "extended-arg-keyword:" 45 | (symbol->string 46 | (syntax-e id)))) 47 | id) 48 | (lambda () #f)))) 49 | (define (flatten-extended-bindings/values stxs expr) 50 | (define temps (generate-temporaries stxs)) 51 | (define (remove-false-2nd l) 52 | (let loop ([l l] [r '()]) 53 | (if (null? l) 54 | (reverse r) 55 | (loop (cdr l) (if (cadar l) (cons (car l) r) r))))) 56 | (let loop (;; tail: listof (cons extended-id, assigned-temp) 57 | [tail (map cons (syntax->list stxs) temps)] 58 | ;; r: listof (list extended-ids new-temps convert-expr) 59 | ;; or (list extended-id same-temp #f) 60 | [r '()] 61 | ;; #f if non-id scanned, otherwise #t or 'first on first pass 62 | [simple? 'first] 63 | ;; vbinds: listof listof listof (vars expr) 64 | [vbinds (list (list (list temps expr)))]) 65 | (if (null? tail) 66 | (let ([r (reverse r)]) 67 | (if simple? 68 | (if (eq? simple? 'first) 69 | (values stxs expr) 70 | (values (datum->syntax-object stxs (map car r) stxs) 71 | (let loop ([vbs (reverse vbinds)]) 72 | (if (null? vbs) 73 | (if (and (pair? r) (null? (cdr r))) 74 | (quasisyntax/loc stxs #,(cadar r)) 75 | (quasisyntax/loc stxs (values #,@(map cadr r)))) 76 | (quasisyntax/loc stxs 77 | (let-values #,(remove-false-2nd (car vbs)) 78 | #,(loop (cdr vbs)))))))) 79 | ;; saw non-identifiers, so start another iteration 80 | (loop (apply append (map (lambda (x) 81 | (if (caddr x) 82 | (map cons (car x) (cadr x)) 83 | (list (cons (car x) (cadr x))))) 84 | r)) 85 | '() #t (cons (map cdr r) vbinds)))) 86 | (syntax-case (caar tail) () 87 | [var (identifier? #'var) 88 | (loop (cdr tail) (cons (list (caar tail) (cdar tail) #f) r) 89 | simple? vbinds)] 90 | [(id . xs) (identifier? #'id) 91 | (cond 92 | [(id->handlers #'id) => 93 | (lambda (handlers) 94 | (let ([bindings (syntax->list ((car handlers) #'xs))] 95 | [new-expr ((cadr handlers) (cdar tail) #'xs)]) 96 | (unless (list? bindings) 97 | (error 'extended-binding 98 | "`~s->bindings' returned a non-list value: ~s" 99 | (syntax-e #'id) bindings)) 100 | (loop (cdr tail) 101 | (cons (list bindings (generate-temporaries bindings) 102 | new-expr) 103 | r) 104 | #f vbinds)))] 105 | [else (raise-syntax-error 106 | 'extended-binding 107 | "got a form which is not an extended binding" 108 | (caar tail) #'id)])] 109 | [_ (raise-syntax-error 110 | 'extended-binding "bad binding" (caar tail))])))) 111 | (define (_define-values stx) 112 | (syntax-case stx () 113 | [(_ (var ...) expr) 114 | (let-values ([(bindings expr) 115 | (flatten-extended-bindings/values #'(var ...) #'expr)]) 116 | (quasisyntax/loc stx (define-values #,bindings #,expr)))])) 117 | (define (_define stx) 118 | (syntax-case stx (values) 119 | [(_ (values x ...) expr) 120 | (syntax/loc stx (define-values~ (x ...) expr))] 121 | [(_ (id . xs) expr) (id->handlers #'id) 122 | (syntax/loc stx (define-values~ ((id . xs)) expr))] 123 | [(_ (id . xs) body0 body ...) 124 | (syntax/loc stx (define-values~ (id) (lambda~ xs body0 body ...)))] 125 | [(_ x expr) 126 | (syntax/loc stx (define-values~ (x) expr))])) 127 | (define (make-let-values let-form) 128 | (lambda (stx) 129 | (syntax-case stx () 130 | [(_ (binding ...) body0 body ...) 131 | (quasisyntax/loc stx 132 | (#,let-form 133 | #,(map (lambda (binding) 134 | (syntax-case binding () 135 | [((var ...) expr) 136 | (let-values ([(bindings expr) 137 | (flatten-extended-bindings/values 138 | #'(var ...) #'expr)]) 139 | (quasisyntax/loc binding 140 | (#,bindings #,expr)))])) 141 | (syntax->list #'(binding ...))) 142 | body0 body ...))]))) 143 | (define _let-values (make-let-values #'let-values)) 144 | (define _let*-values (make-let-values #'let*-values)) 145 | (define _letrec-values (make-let-values #'letrec-values)) 146 | (define (make-let let-form label?) 147 | (lambda (stx) 148 | (syntax-case stx () 149 | [(_ label ((var val) ...) body0 body ...) 150 | (and label? (identifier? #'label)) 151 | (quasisyntax/loc stx 152 | ((letrec~ ([label (lambda~ (var ...) body0 body ...)]) label) 153 | val ...))] 154 | [(_ (binding ...) body0 body ...) 155 | (quasisyntax/loc stx 156 | (#,let-form #,(map (lambda (binding) 157 | (syntax-case binding (values) 158 | [((values x ...) expr) #'((x ...) expr)] 159 | [(x expr) #'((x) expr)])) 160 | (syntax->list #'(binding ...))) 161 | body0 body ...))]))) 162 | (define _let (make-let #'let-values~ #t)) 163 | (define _let* (make-let #'let*-values~ #f)) 164 | (define _letrec (make-let #'letrec-values~ #f)) 165 | (define (_set! stx) 166 | (syntax-case stx (values) 167 | [(_ (values x ...) expr) (syntax/loc stx (set!-values~ (x ...) expr))] 168 | [(_ x expr) (syntax/loc stx (set!-values~ (x) expr))])) 169 | (define (_set!-values stx) 170 | (syntax-case stx () 171 | [(_ (var ...) expr) 172 | (let-values ([(bindings expr) 173 | (flatten-extended-bindings/values #'(var ...) #'expr)]) 174 | (quasisyntax/loc stx 175 | (set!-values #,bindings #,expr)))])) 176 | (define (_lambda stx) 177 | (syntax-case stx () 178 | [(_ vars body0 body ...) 179 | (let loop ([vs #'vars] [newvars '()] [specials '()] [restarg '()]) 180 | (syntax-case vs () 181 | [((id xs ...) . rest) (identifier? #'id) 182 | (let ([newvar (car (generate-temporaries #'(id)))]) 183 | (loop #'rest (cons newvar newvars) 184 | (cons (list #'(id xs ...) newvar) specials) 185 | restarg))] 186 | [(id . rest) (identifier? #'id) 187 | (loop #'rest (cons #'id newvars) specials restarg)] 188 | [id (identifier? #'id) 189 | (loop #'() newvars specials #'id)] 190 | [() (let ([args (datum->syntax-object 191 | #'vars (append (reverse newvars) restarg) 192 | #'vars)]) 193 | (if (null? specials) 194 | (quasisyntax/loc stx (lambda #,args body0 body ...)) 195 | (quasisyntax/loc stx 196 | (lambda #,args 197 | (let~ #,(reverse specials) 198 | body0 body ...)))))]))])) 199 | (values _define-values 200 | _define 201 | _let-values 202 | _let*-values 203 | _letrec-values 204 | _let 205 | _let* 206 | _letrec 207 | _set! 208 | _set!-values 209 | _lambda))) 210 | 211 | ;; These are used as procedures for the syntax level 212 | (provide extended-arg-keyword:list extended-arg-keyword:vector) 213 | (define-syntax extended-arg-keyword:list 214 | (list (lambda (vars) vars) 215 | (lambda (expr vars) 216 | (quasisyntax/loc expr (apply values #,expr))))) 217 | (define-syntax extended-arg-keyword:vector 218 | (list (lambda (vars) vars) 219 | (lambda (expr vars) 220 | (quasisyntax/loc expr (apply values (vector->list #,expr)))))) 221 | 222 | ;; quote turns implicit lists and vectors to explicit ones 223 | (provide extended-arg-keyword:quote) 224 | (define-syntax extended-arg-keyword:quote 225 | (list (lambda (vars) 226 | (define (do-vars vs) 227 | (datum->syntax-object 228 | vs (map (lambda (v) 229 | (if (identifier? v) v (quasisyntax/loc v '#,v))) 230 | (syntax->list vs)) 231 | vs)) 232 | (do-vars (syntax-case vars () 233 | [((v ...)) #'(v ...)] [(#(v ...)) #'(v ...)]))) 234 | (lambda (expr vars) 235 | (syntax-case vars () 236 | [((v ...)) 237 | (quasisyntax/loc expr (apply values #,expr))] 238 | [(#(v ...)) 239 | (quasisyntax/loc expr (apply values (vector->list #,expr)))])))) 240 | 241 | ;; (define (values a (list (vector b c) (vector d) (list)) e) 242 | ;; (values 1 (list (vector 2 3) (vector 4) (list)) 5)) 243 | ;; (list a b c d e) 244 | ;; (let ([(values a (list (vector b c) (vector d) (list)) e) 245 | ;; (values 1 (list (vector 2 3) (vector 4) (list)) 5)]) 246 | ;; (list a b c d e)) 247 | ;; (let* ([(list x y) (list 1 2)] [(list x y) (list y x)]) (list x y)) 248 | ;; (let ([(values a '(#(b c) #(d) ()) e) 249 | ;; (values 1 '(#(2 3) #(4) ()) 5)]) 250 | ;; (list a b c d e)) 251 | ;; (map (lambda ((list x y)) (list y x)) '((1 2) (3 4))) 252 | ;; (let loop ([(list str n) (list "foo" 10)]) 253 | ;; (if (zero? n) str (loop (list (string-append str "!") (sub1 n))))) 254 | ;; 255 | ;; (module foo mzscheme 256 | ;; (provide (struct point (x y)) extended-arg-keyword:make-point) 257 | ;; (define-struct point (x y)) 258 | ;; (define-syntax extended-arg-keyword:make-point 259 | ;; (list (lambda (vars) (syntax-case vars () ((x y) vars))) 260 | ;; (lambda (expr vars) 261 | ;; (quasisyntax/loc expr 262 | ;; (values (point-x #,expr) (point-y #,expr))))))) 263 | ;; (require foo) 264 | ;; (define a (make-point 1 2)) 265 | ;; (let ([(make-point x y) a]) (+ x y)) 266 | -------------------------------------------------------------------------------- /setf.rkt: -------------------------------------------------------------------------------- 1 | ;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org) 2 | 3 | ;;> This module provides the forms `setf!', `psetf!', and `setf!-values' for 4 | ;;> generic setters, much like CL's `setf', and `psetf', and a form similar 5 | ;;> to Racket's `set!-values'. Note that when these are later re-exported 6 | ;;> (by `turbo'), they are renamed as `set!', `pset!', and `set!-values' 7 | ;;> (overriding the built-in `set!' and `set!-values'). Also, note that 8 | ;;> this just defines the basic functionality, the `misc' module defines 9 | ;;> many common setters. 10 | 11 | #lang mzscheme 12 | 13 | ;;>> (setf! place value ...) 14 | ;;> Expand `(setf! (foo ...) v)' to `(set-foo! ... v)'. The generated 15 | ;;> `set-foo!' identifier has the same syntax context as `foo', which 16 | ;;> means that to use this for some `foo' you need to define `set-foo!' 17 | ;;> either as a function or a syntax in the same definition context of 18 | ;;> `foo'. The nice feature that comes out of this and the syntax system 19 | ;;> is that examples like the following work as expected: 20 | ;;> (let ([foo mcar] [set-foo! set-mcar!]) (setf! (foo a) 11)) 21 | ;;> 22 | ;;> `place' gets expanded before this processing is done so macros work 23 | ;;> properly. If the place is not a form, then this will just use the 24 | ;;> standard `set!'. 25 | ;;> 26 | ;;> Another extension of the original `set!' is that it allows changing 27 | ;;> several places in sequence -- `(setf! x a y b)' will set `x' to `a' 28 | ;;> and then set `y' to `b'. 29 | ;; Original idea thanks to Eric Kidd who stole it from Dylan 30 | (provide setf!) 31 | (define-syntax (setf! stx) 32 | (define (set!-prefix id) 33 | (datum->syntax-object 34 | id 35 | (string->symbol (string-append "set-" (symbol->string (syntax-e id)) "!")) 36 | id id)) 37 | (syntax-case stx (setf!) 38 | ;; if the getter is a set!-transformer, make it do its thing 39 | [(setf! getter . xs) 40 | (and (identifier? #'getter) 41 | (set!-transformer? (syntax-local-value #'getter (lambda () #f)))) 42 | ((set!-transformer-procedure (syntax-local-value #'getter)) stx)] 43 | [(setf! place val) 44 | ;; need to expand place first, in case it is itself a macro 45 | (with-syntax ([place (local-expand 46 | #'place 'expression 47 | (append (list #'#%app #'#%top #'#%datum) 48 | (map (lambda (s) 49 | (datum->syntax-object #'place s #f)) 50 | '(#%app #%top #%datum))))]) 51 | (syntax-case #'place () 52 | [(getter args ...) 53 | (if (identifier? #'getter) 54 | (with-syntax ([setter (set!-prefix #'getter)]) 55 | (syntax/loc stx (setter args ... val))) 56 | (raise-syntax-error #f "not an identifier" stx #'getter))] 57 | [_ (syntax/loc stx (set! place val))]))] 58 | [(setf! place val . more) 59 | (let loop ([pvs #'(place val . more)] [r '()]) 60 | (syntax-case pvs () 61 | [(p v . more) 62 | (loop #'more (cons (syntax/loc stx (setf! p v)) r))] 63 | [() (quasisyntax/loc stx (begin #,@(reverse r)))] 64 | [_ (raise-syntax-error #f "uneven number of forms" stx)]))])) 65 | 66 | ;;>> (psetf! place value ...) 67 | ;;> This is very similar to `setf!' above, except that the change to the 68 | ;;> places is done *simultaneously*. For example, `(setf! x y y x)' 69 | ;;> switches the values of the two variables. 70 | ;; This could have been expressed using `setf!-values', but that would lead to 71 | ;; an unnecessary creation of a values tuple. 72 | (provide psetf!) 73 | (define-syntax (psetf! stx) 74 | (syntax-case stx () 75 | ;; optimize common case 76 | [(_ place val) (syntax/loc stx (setf! place val))] 77 | [(_ more ...) 78 | (let loop ([vars '()] [vals '()] [more (syntax->list #'(more ...))]) 79 | (cond 80 | [(null? more) 81 | (let ([vars (reverse vars)] 82 | [vals (reverse vals)] 83 | [tmps (generate-temporaries (map (lambda (x) 'x) vars))]) 84 | (quasisyntax/loc stx 85 | (let #,(map (lambda (t v) #`(#,t #,v)) tmps vals) 86 | #,@(map (lambda (v t) #`(setf! #,v #,t)) vars tmps))))] 87 | [(null? (cdr more)) 88 | (raise-syntax-error #f "uneven number of forms" stx)] 89 | [else (loop (cons (car more) vars) (cons (cadr more) vals) 90 | (cddr more))]))])) 91 | 92 | ;;>> (setf!-values (place ...) expr) 93 | ;;> This is a version of `setf!', that works with multiple values. `expr' 94 | ;;> is expected to evaluate to the correct number of values, and these are 95 | ;;> then put into the specified places which can be an place suited to 96 | ;;> `setf!'. Note that no duplication of identifiers is checked, if an 97 | ;;> identifier appears more than once then it will have the last assigned 98 | ;;> value. 99 | (provide setf!-values) 100 | (define-syntax (setf!-values stx) 101 | (syntax-case stx () 102 | ;; optimize common case 103 | [(_ (place) val) (syntax/loc stx (setf! place val))] 104 | [(_ (place ...) values) 105 | (with-syntax ([(temp ...) (datum->syntax-object 106 | #'(place ...) 107 | (generate-temporaries #'(place ...)) 108 | #'(place ...))]) 109 | (syntax/loc stx 110 | (let-values ([(temp ...) values]) 111 | (setf! place temp) ...)))])) 112 | 113 | ;;>> (set-values! places ... values-expr) 114 | ;;>> (set-list! places ... list-expr) 115 | ;;>> (set-vector! places ... vector-expr) 116 | ;;> These are defined as special forms that use `setf!-values' to set the 117 | ;;> given places to the appropriate components of the third form. This 118 | ;;> allows foing the following: 119 | ;;> => (define (values a b c) (values 1 2 3)) 120 | ;;> => (setf! (values a b c) (values 11 22 33)) 121 | ;;> => (list a b c) 122 | ;;> (11 22 33) 123 | ;;> => (setf! (list a b c) (list 111 222 333)) 124 | ;;> => (list a b c) 125 | ;;> (111 222 333) 126 | ;;> => (setf! (list a b c) (list 1111 2222 3333)) 127 | ;;> => (list a b c) 128 | ;;> (1111 2222 3333) 129 | ;;> Furthermore, since the individual setting of each place is eventually 130 | ;;> done with `setf!', then this can be used recursively: 131 | ;;> => (set! (list a (vector b) (vector c c)) '(2 #(3) #(4 5))) 132 | ;;> => (list a b c) 133 | ;;> (2 3 5) 134 | (provide set-values! set-list! set-vector!) 135 | (define-syntaxes (set-values! set-list! set-vector!) 136 | (let ([make-setter 137 | (lambda (convert) 138 | (lambda (stx) 139 | (syntax-case stx () 140 | [(_ x y ...) 141 | (let loop ([args (syntax->list #'(x y ...))] [as '()]) 142 | (if (null? (cdr args)) 143 | (quasisyntax/loc stx 144 | (setf!-values #,(datum->syntax-object 145 | #'(x y ...) (reverse as) #'(x y ...)) 146 | #,(convert (car args)))) 147 | (loop (cdr args) (cons (car args) as))))])))]) 148 | (values 149 | ;; set-values! 150 | (make-setter (lambda (x) x)) 151 | ;; set-list! 152 | (make-setter (lambda (x) #`(apply values #,x))) 153 | ;; set-vector! 154 | (make-setter (lambda (x) #`(apply values (vector->list #,x))))))) 155 | 156 | (provide shift! rotate! inc! dec! push! pop!) 157 | (define-syntaxes (shift! rotate! inc! dec! push! pop!) 158 | (let* ([protect-indexes 159 | (lambda (place body) 160 | (syntax-case place () 161 | [(getter . xs) 162 | (let ([bindings+expr 163 | (let loop ([xs #'xs] 164 | [bindings '()] 165 | [expr (list #'getter)] 166 | [all-ids? #t]) 167 | (syntax-case xs () 168 | [() (and (not all-ids?) 169 | (cons (reverse bindings) (reverse expr)))] 170 | [(x . xs) 171 | (let ([new (datum->syntax-object 172 | #'x (gensym) #'x)]) 173 | (loop #'xs 174 | (cons (list new #'x) bindings) 175 | (cons new expr) 176 | (and (identifier? #'x) all-ids?)))] 177 | [x (and (not (and all-ids? (identifier? #'x))) 178 | (let ([new (datum->syntax-object 179 | #'x (gensym) #'x)]) 180 | (cons (reverse (cons (list new #'x) 181 | bindings)) 182 | (append (reverse expr) new))))]))]) 183 | (if bindings+expr 184 | #`(let #,(car bindings+expr) #,(body (cdr bindings+expr))) 185 | (body place)))] 186 | [_ (body place)]))] 187 | [protect-indexes-list 188 | (lambda (places body) 189 | (let loop ([ps places] [r '()]) 190 | (if (null? ps) 191 | (body (reverse r)) 192 | (protect-indexes (car ps) (lambda (p) 193 | (loop (cdr ps) (cons p r)))))))]) 194 | (values 195 | ;;>> (shift! place ... newvalue) 196 | ;;> This is similar to CL's `shiftf' -- it is roughly equivalent to 197 | ;;> (begin0 place1 198 | ;;> (psetf! place1 place2 199 | ;;> place2 place3 200 | ;;> ... 201 | ;;> placen newvalue)) 202 | ;;> except that it avoids evaluating index subforms twice, for example: 203 | ;;> => (let ([foo (lambda (x) (printf ">>> ~s\n" x) x)] 204 | ;;> [a '(1)] [b '(2)]) 205 | ;;> (list (shift! (car (foo a)) (car (foo b)) 3) a b)) 206 | ;;> >>> (1) 207 | ;;> >>> (2) 208 | ;;> (1 (2) (3)) 209 | ;; --- shift! 210 | (lambda (stx) 211 | (syntax-case stx () 212 | [(_ x y more ...) 213 | (protect-indexes-list (syntax->list #'(x y more ...)) 214 | (lambda (vars) 215 | (let loop ([vs vars] [r '()]) 216 | (if (null? (cdr vs)) 217 | (quasisyntax/loc stx 218 | (let ([v #,(car vars)]) 219 | (psetf! #,@(datum->syntax-object 220 | #'(x y more ...) 221 | (reverse r) 222 | #'(x y more ...))) 223 | v)) 224 | (loop (cdr vs) (list* (cadr vs) (car vs) r))))))])) 225 | ;;>> (rotate! place ...) 226 | ;;> This is similar to CL's `rotatef' -- it is roughly equivalent to 227 | ;;> (psetf! place1 place2 228 | ;;> place2 place3 229 | ;;> ... 230 | ;;> placen place1) 231 | ;;> except that it avoids evaluating index subforms twice. 232 | ;; --- rotate! 233 | (lambda (stx) 234 | (syntax-case stx () 235 | [(_ x) #'(void)] 236 | [(_ x xs ...) 237 | (protect-indexes-list (syntax->list #'(x xs ...)) 238 | (lambda (vars) 239 | (let loop ([vs vars] [r '()]) 240 | (if (null? (cdr vs)) 241 | (quasisyntax/loc stx 242 | (psetf! #,@(datum->syntax-object 243 | #'(x xs ...) 244 | (reverse (list* (car vars) (car vs) r)) 245 | #'(x xs ...)))) 246 | (loop (cdr vs) (list* (cadr vs) (car vs) r))))))])) 247 | ;;>> (inc! place [delta]) 248 | ;;>> (dec! place [delta]) 249 | ;;>> (push! x place) 250 | ;;>> (pop! place) 251 | ;;> These are some simple usages of `setf!'. Note that they also avoid 252 | ;;> evaluating any indexes twice. 253 | ;; --- inc! 254 | (lambda (stx) 255 | (syntax-case stx () 256 | [(_ p) #'(_ p 1)] 257 | [(_ p d) (protect-indexes #'p 258 | (lambda (p) #`(setf! #,p (+ #,p d))))])) 259 | ;; --- dec! 260 | (lambda (stx) 261 | (syntax-case stx () 262 | [(_ p) #'(_ p 1)] 263 | [(_ p d) (protect-indexes #'p 264 | (lambda (p) #`(setf! #,p (- #,p d))))])) 265 | ;; --- push! 266 | (lambda (stx) 267 | (syntax-case stx () 268 | [(_ x p) (protect-indexes #'p 269 | (lambda (p) #`(setf! #,p (cons x #,p))))])) 270 | ;; --- pop! 271 | (lambda (stx) 272 | (syntax-case stx () 273 | [(_ p) (protect-indexes #'p 274 | (lambda (p) 275 | #`(let ([p1 #,p]) 276 | (begin0 (car p1) (setf! #,p (cdr p1))))))]))))) 277 | -------------------------------------------------------------------------------- /base.rkt: -------------------------------------------------------------------------------- 1 | ;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org) 2 | 3 | ;;> The `base' module defines some basic low-level syntactic extensions to 4 | ;;> Racket. It can be used by itself to get these extensions. 5 | 6 | #lang mzscheme 7 | 8 | (provide (all-from-except mzscheme 9 | #%module-begin #%top #%app define let let* letrec lambda 10 | keyword? keyword->string string->keyword)) 11 | 12 | ;;>> (#%module-begin ...) 13 | ;;> `base' is a language module -- it redefines `#%module-begin' to load 14 | ;;> itself for syntax definitions. 15 | (provide (rename module-begin~ #%module-begin)) 16 | (define-syntax (module-begin~ stx) 17 | (let ([e (if (syntax? stx) (syntax-e stx) stx)]) 18 | (if (pair? e) 19 | (datum->syntax-object 20 | (quote-syntax here) 21 | (list* (quote-syntax #%plain-module-begin) 22 | (datum->syntax-object 23 | stx (list (quote-syntax require-for-syntax) 'swindle/base)) 24 | (cdr e)) 25 | stx) 26 | (raise-syntax-error #f "bad syntax" stx))) 27 | ;; This doesn't work anymore (from 203.4) 28 | ;; (syntax-rules () 29 | ;; [(_ . body) (#%plain-module-begin 30 | ;; (require-for-syntax swindle/base) . body)]) 31 | ) 32 | 33 | ;;>> (#%top . id) 34 | ;;> This special syntax is redefined to make keywords (symbols whose names 35 | ;;> begin with a ":") evaluate to themselves. 36 | (provide (rename top~ #%top)) 37 | (define-syntax (top~ stx) 38 | (syntax-case stx () 39 | [(_ . x) 40 | (let ([s (syntax-e #'x)]) 41 | (if (and (symbol? s) 42 | (not (eq? s '||)) 43 | (eq? #\: (string-ref (symbol->string s) 0))) 44 | (syntax/loc stx (#%datum . x)) 45 | (syntax/loc stx (#%top . x))))])) 46 | 47 | ;;>> (#%app ...) 48 | ;;> Redefined so it is possible to apply using dot notation: `(foo x . y)' 49 | ;;> is the same as `(apply foo x y)'. This is possible only when the last 50 | ;;> (dotted) element is an identifier. 51 | (provide (rename app~ #%app)) 52 | (define-syntax (app~ stx) 53 | (syntax-case stx () 54 | [(_ x ...) (syntax/loc stx (#%app x ...))] 55 | [(_ . x) 56 | (let loop ([s (syntax-e #'x)] [r '()]) 57 | (cond [(list? s) (syntax/loc stx (#%app . x))] 58 | [(pair? s) (loop (cdr s) (cons (car s) r))] 59 | [else (let ([e (and (syntax? s) (syntax-e s))]) 60 | (if (or (null? e) (pair? e)) 61 | (loop e r) 62 | (quasisyntax/loc stx 63 | (#%app apply . #,(reverse (cons s r))))))]))])) 64 | 65 | ;; these are defined as normal bindings so code that uses this module can use 66 | ;; them, but for the syntax level of this module we need them too. 67 | (define-for-syntax (keyword*? x) 68 | (and (symbol? x) (not (eq? x '||)) 69 | (eq? (string-ref (symbol->string x) 0) #\:))) 70 | (define-for-syntax (syntax-keyword? x) 71 | (keyword*? (if (syntax? x) (syntax-e x) x))) 72 | 73 | ;;>> (define id-or-list ...) 74 | ;;> The standard `define' form is modified so defining :keywords is 75 | ;;> forbidden, and if a list is used instead of an identifier name for a 76 | ;;> function then a curried function is defined. 77 | ;;> => (define (((plus x) y) z) (+ x y z)) 78 | ;;> => plus 79 | ;;> # 80 | ;;> => (plus 5) 81 | ;;> # 82 | ;;> => ((plus 5) 6) 83 | ;;> # 84 | ;;> => (((plus 5) 6) 7) 85 | ;;> 18 86 | ;;> Note the names of intermediate functions. 87 | ;;> 88 | ;;> In addition, the following form can be used to define multiple values: 89 | ;;> => (define (values a b) (values 1 2)) 90 | (provide (rename define~ define)) 91 | (define-syntax (define~ stx) 92 | ;; simple version 93 | ;; (syntax-case stx () 94 | ;; [(_ (name arg ...) body ...) 95 | ;; #`(define~ name (lambda~ (arg ...) body ...))] 96 | ;; [(_ name body ...) #'(define name body ...)]) 97 | ;; this version makes created closures have meaningful names 98 | ;; also -- forbid using :keyword identifiers 99 | ;; also -- make (define (values ...) ...) a shortcut for define-values (this 100 | ;; is just a patch, a full solution should override `define-values', and 101 | ;; also deal with `let...' and `let...-values' and lambda binders) 102 | ;; also -- if the syntax is top-level, then translate all defines into a 103 | ;; define with (void) followed by a set! -- this is for the problem of 104 | ;; defining something that is provided by some module, and re-binding a 105 | ;; syntax 106 | (define top-level? (eq? 'top-level (syntax-local-context))) 107 | (syntax-case* stx (values) 108 | ;; compare symbols if at the top-level 109 | (if top-level? 110 | (lambda (x y) (eq? (syntax-e x) (syntax-e y))) 111 | module-identifier=?) 112 | [(_ name expr) (identifier? #'name) 113 | (cond [(syntax-keyword? #'name) 114 | (raise-syntax-error #f "cannot redefine a keyword" stx #'name)] 115 | [top-level? 116 | (syntax/loc stx 117 | (begin (define-values (name) (void)) (set! name expr)))] 118 | [else 119 | (syntax/loc stx (define-values (name) expr))])] 120 | [(_ (values name ...) expr) 121 | (cond [(ormap (lambda (id) (and (syntax-keyword? id) id)) 122 | (syntax->list #'(name ...))) 123 | => (lambda (id) 124 | (raise-syntax-error #f "cannot redefine a keyword" stx id))] 125 | [top-level? 126 | (syntax/loc stx 127 | (begin (define name (void)) ... (set!-values (name ...) expr)))] 128 | [else (syntax/loc stx (define-values (name ...) expr))])] 129 | [(_ names body0 body ...) (pair? (syntax-e #'names)) 130 | (let loop ([s #'names] [args '()]) 131 | (syntax-case s () 132 | [(name . arg) (loop #'name (cons #'arg args))] 133 | [name 134 | (let ([sym (syntax-object->datum #'name)]) 135 | (let loop ([i (sub1 (length args))] 136 | [as (reverse (cdr args))] 137 | [body #'(begin body0 body ...)]) 138 | (if (zero? i) 139 | (cond [(syntax-keyword? #'name) 140 | (raise-syntax-error 141 | #f "cannot redefine a keyword" stx #'name)] 142 | [top-level? 143 | (quasisyntax/loc stx 144 | (begin (define name (void)) 145 | (set! name (lambda~ #,(car args) #,body))))] 146 | [else 147 | (quasisyntax/loc stx 148 | (define name (lambda~ #,(car args) #,body)))]) 149 | (loop (sub1 i) (cdr as) 150 | (syntax-property 151 | (quasisyntax/loc stx (lambda~ #,(car as) #,body)) 152 | 'inferred-name 153 | (string->symbol (format "~a:~a" sym i)))))))]))])) 154 | 155 | ;;>> (let ([id-or-list ...] ...) ...) 156 | ;;>> (let* ([id-or-list ...] ...) ...) 157 | ;;>> (letrec ([id-or-list ...] ...) ...) 158 | ;;> All standard forms of `let' are redefined so they can generate 159 | ;;> functions using the same shortcut that `define' allows. This includes 160 | ;;> the above extension to the standard `define'. For example: 161 | ;;> => (let ([((f x) y) (+ x y)]) ((f 1) 2)) 162 | ;;> 3 163 | ;;> It also includes the `values' keyword in a similar way to `define'. 164 | ;;> For example: 165 | ;;> => (let ([(values i o) (make-pipe)]) i) 166 | ;;> # 167 | (provide (rename let~ let) (rename let*~ let*) (rename letrec~ letrec)) 168 | (define-syntaxes (let~ let*~ letrec~) 169 | (let* ([process 170 | (lambda (stx var0 val0 . flat?) 171 | (syntax-case var0 (values) 172 | [(values var ...) (null? flat?) #`((var ...) . #,val0)] 173 | [_ (let loop ([var var0] [args '()]) 174 | (if (identifier? var) 175 | (if (null? args) 176 | (let ([val (syntax->list val0)]) 177 | (if (and (pair? val) (null? (cdr val))) 178 | (list (if (null? flat?) (list var) var) (car val)) 179 | (raise-syntax-error 180 | #f "bad binding" stx #`(#,var0 #,@val0)))) 181 | (let ([sym (syntax-e var)]) 182 | (let loop ([i (sub1 (length args))] 183 | [as (reverse args)] 184 | [val val0]) 185 | (if (< i 0) 186 | (list (if (null? flat?) (list var) var) 187 | (car (syntax->list val))) 188 | (loop (sub1 i) (cdr as) 189 | (let ([val #`((lambda~ #,(car as) #,@val))]) 190 | (if (zero? i) 191 | val 192 | (syntax-property 193 | val 'inferred-name 194 | (if (zero? i) 195 | sym 196 | (string->symbol 197 | (format "~a:~a" sym i))))))))))) 198 | (syntax-case var () 199 | [(var . args1) (loop #'var (cons #'args1 args))])))]))] 200 | [mk-bindings 201 | (lambda (stx bindings . flat?) 202 | (syntax-case bindings () 203 | [((var val more ...) ...) 204 | (datum->syntax-object 205 | #'bindings 206 | (map (lambda (x y) (apply process stx x y flat?)) 207 | (syntax->list #'(var ...)) 208 | (syntax->list #'((val more ...) ...))) 209 | #'bindings)]))] 210 | [mk-let 211 | (lambda (tag . lbl) 212 | (lambda (stx) 213 | (syntax-case stx () 214 | [(_ label bindings body0 body ...) 215 | (and (identifier? #'label) (pair? lbl)) 216 | (quasisyntax/loc stx 217 | (#,(car lbl) label #,(mk-bindings stx #'bindings #t) 218 | body0 body ...))] 219 | [(_ bindings body0 body ...) 220 | (quasisyntax/loc stx 221 | (#,tag #,(mk-bindings stx #'bindings) body0 body ...))])))]) 222 | (values (mk-let #'let-values #'let) 223 | (mk-let #'let*-values) 224 | (mk-let #'letrec-values)))) 225 | 226 | ;;>> (lambda formals body ...) 227 | ;;> The standard `lambda' is extended with Lisp-like &-keywords in its 228 | ;;> argument list. This extension is available using the above short 229 | ;;> syntax. There is one important difference between these keywords and 230 | ;;> Lisp: some &-keywords are used to access arguments that follow the 231 | ;;> keyword part of the arguments. This makes it possible to write 232 | ;;> procedures that can be invoked as follows: 233 | ;;> (f ) 234 | ;;> (Note: do not use more keywords after the !) 235 | ;;> 236 | ;;> Available &-keywords are: 237 | (provide (rename lambda~ lambda)) 238 | (define-syntax (lambda~ stx) 239 | (define (process-optional-arg o) 240 | (syntax-case o () 241 | [(var default) (identifier? #'var) (list #'var #'default)] 242 | [(var) (identifier? #'var) (list #'var #'#f)] 243 | [var (identifier? #'var) (list #'var #'#f)] 244 | [var (raise-syntax-error #f "not a valid &optional spec" stx #'var)])) 245 | (define (process-keyword-arg k) 246 | (define (key var) 247 | (datum->syntax-object 248 | k 249 | (string->symbol 250 | (string-append ":" (symbol->string (syntax-object->datum var)))) 251 | k k)) 252 | (syntax-case k () 253 | [(var key default) 254 | (and (identifier? #'var) (syntax-keyword? #'key)) 255 | (list #'var #'key #'default)] 256 | [(var default) (identifier? #'var) (list #'var (key #'var) #'default)] 257 | [(var) (identifier? #'var) (list #'var (key #'var) #'#f)] 258 | [var (identifier? #'var) (list #'var (key #'var) #'#f)] 259 | [var (raise-syntax-error #f "not a valid &key spec" stx #'var)])) 260 | (syntax-case stx () 261 | [(_ formals expr0 expr ...) 262 | (let ([vars '()] 263 | [opts '()] 264 | [keys '()] 265 | [rest #f] ; keys and all (no optionals) 266 | [rest-keys #f] ; like the above, minus specified keys 267 | [body #f] ; stuff that follows all keywords 268 | [all-keys #f] ; all keys, excluding body 269 | [other-keys #f]) ; unprocessed keys, excluding body 270 | ;; relations: 271 | ;; rest = (append all-keys body) 272 | ;; rest-keys = (append other-keys body) 273 | (let loop ([state #f] [args #'formals]) 274 | (syntax-case args () 275 | [() #f] 276 | [(v . xs) 277 | (let* ([v #'v] 278 | [k (if (symbol? v) v (and (identifier? v) (syntax-e v)))] 279 | [x (and k (symbol->string k))]) 280 | (cond 281 | ;; check &-keywords according to their name, so something like 282 | ;; (let ([&rest 1]) (lambda (&rest r) ...)) 283 | ;; works as expected 284 | [(and x (> (string-length x) 0) (eq? #\& (string-ref x 0))) 285 | (case k 286 | ;;> * &optional, &opt, &opts: denote an optional argument, possibly with a 287 | ;;> default value (if the variable is specified as `(var val)'). 288 | ;;> => ((lambda (x &optional y [z 3]) (list x y z)) 1) 289 | ;;> (1 #f 3) 290 | ;;> => ((lambda (x &optional y [z 3]) (list x y z)) 1 2 #f) 291 | ;;> (1 2 #f) 292 | [(&optional &optionals &opt &opts) 293 | (if state 294 | (raise-syntax-error 295 | #f "misplaced &optional argument" stx #'formals) 296 | (loop 'o #'xs))] 297 | ;;> * &keys, &key: a keyword argument -- the variable should be specified 298 | ;;> as `x' or `(x)' to be initialized by an `:x' keyword, `(x v)' to 299 | ;;> specify a default value `v', and `(x k v)' to further specify an 300 | ;;> arbitrary keyword `k'. 301 | ;;> => ((lambda (&key x [y 2] [z :zz 3]) (list x y z)) :x 'x :zz 'z) 302 | ;;> (x 2 z) 303 | ;;> Note that keyword values take precedence on the left, and that 304 | ;;> keywords are not verified: 305 | ;;> => ((lambda (&key y) y) :y 1 :z 3 :y 2) 306 | ;;> 1 307 | [(&key &keys) 308 | (if (memq state '(#f o r!)) 309 | (loop 'k #'xs) 310 | (raise-syntax-error 311 | #f "misplaced &keys argument" stx #'formals))] 312 | ;;> * &rest: a `rest' argument which behaves exactly like the Scheme dot 313 | ;;> formal parameter (actually a synonym for it: can't use both). Note 314 | ;;> that in case of optional arguments, the rest variable holds any 315 | ;;> arguments that were not used for defaults, but using keys doesn't 316 | ;;> change its value. For example: 317 | ;;> => ((lambda (x &rest r) r) 1 2 3) 318 | ;;> (2 3) 319 | ;;> => ((lambda (x &optional y &rest r) r) 1) 320 | ;;> () 321 | ;;> => ((lambda (x &optional y &rest r) r) 1 2 3) 322 | ;;> (3) 323 | ;;> => ((lambda (x &optional y . r) r) 1 2 3) 324 | ;;> (3) 325 | ;;> => ((lambda (x &key y &rest r) (list y r)) 1 :y 2 3 4) 326 | ;;> (2 (:y 2 3 4)) 327 | ;;> => ((lambda (x &key y &rest r) (list y r)) 1 :y 2 3 4 5) 328 | ;;> (2 (:y 2 3 4 5)) 329 | ;;> Note that the last two examples indicate that there is no error if 330 | ;;> the given argument list is not balanced. 331 | [(&rest) 332 | (if (pair? (syntax-e #'xs)) 333 | (loop 'r #'xs) 334 | (raise-syntax-error 335 | #f "no name for &rest argument" stx #'formals))] 336 | ;;> * &rest-keys: similar to `&rest', but all specified keys are removed 337 | ;;> with their values. 338 | ;;> => ((lambda (x &key y &rest r) r) 1 :x 2 :y 3) 339 | ;;> (:x 2 :y 3) 340 | ;;> => ((lambda (x &key y &rest-keys r) r) 1 :x 2 :y 3) 341 | ;;> (:x 2) 342 | [(&rest-keys) 343 | (if (pair? (syntax-e #'xs)) 344 | (loop 'rk #'xs) 345 | (raise-syntax-error 346 | #f "no name for &rest-keys argument" stx #'formals))] 347 | ;;> * &body: similar to `&rest-keys', but all key/values are removed one 348 | ;;> by one until a non-key is encountered. (Warning: this is *not* the 349 | ;;> same as in Common Lisp!) 350 | ;;> => ((lambda (x &key y &body r) r) 1 :x 2 :y 3) 351 | ;;> () 352 | ;;> => ((lambda (x &key y &body r) r) 1 :x 2 :y 3 5 6) 353 | ;;> (5 6) 354 | [(&body &rest-all-keys) ; &rest-all-keys for compatibility 355 | (if (pair? (syntax-e #'xs)) 356 | (loop 'b #'xs) 357 | (raise-syntax-error 358 | #f "no name for &body argument" 359 | stx #'formals))] 360 | ;;> * &all-keys: the list of all keys+vals, without a trailing body. 361 | ;;> => ((lambda (&keys x y &all-keys r) r) :x 1 :z 2 3 4) 362 | ;;> (:x 1 :z 2) 363 | [(&all-keys) 364 | (if (pair? (syntax-e #'xs)) 365 | (loop 'ak #'xs) 366 | (raise-syntax-error 367 | #f "no name for &all-keys argument" 368 | stx #'formals))] 369 | ;;> * &other-keys: the list of unprocessed keys+vals, without a trailing 370 | ;;> body. 371 | ;;> => ((lambda (&keys x y &other-keys r) r) :x 1 :z 2 3 4) 372 | ;;> (:z 2) 373 | [(&other-keys) 374 | (if (pair? (syntax-e #'xs)) 375 | (loop 'ok #'xs) 376 | (raise-syntax-error 377 | #f "no name for &other-keys argument" 378 | stx #'formals))] 379 | ;;> 380 | ;;> Finally, here is an example where all &rest-like arguments are 381 | ;;> different: 382 | ;;> => ((lambda (&keys x y 383 | ;;> &rest r 384 | ;;> &rest-keys rk 385 | ;;> &body b 386 | ;;> &all-keys ak 387 | ;;> &other-keys ok) 388 | ;;> (list r rk b ak ok)) 389 | ;;> :z 1 :x 2 2 3 4) 390 | ;;> ((:z 1 :x 2 2 3 4) (:z 1 2 3 4) (2 3 4) (:z 1 :x 2) (:z 1)) 391 | ;;> Note that the following invariants hold: 392 | ;;> * rest = (append all-keys body) 393 | ;;> * rest-keys = (append other-keys body) 394 | [else (raise-syntax-error 395 | #f "unknown lambda &-keyword" stx v)])] 396 | [(not (or x (memq state '(o k)))) 397 | (raise-syntax-error #f "not an identifier" stx v)] 398 | [else 399 | (let ([test (lambda (var name) 400 | (if var 401 | (raise-syntax-error 402 | #f (format "too many &~a arguments" name) 403 | stx #'formals) 404 | (set! state 'r!)))]) 405 | (case state 406 | [(#f) (set! vars (cons v vars))] 407 | [(o) (set! opts (cons v opts))] 408 | [(k) (set! keys (cons v keys))] 409 | [(r!) (raise-syntax-error 410 | #f "second identifier after a &rest or similar" 411 | stx v)] 412 | [(r) (test rest 'rest ) (set! rest v)] 413 | [(rk) (test rest-keys 'rest-keys ) (set! rest-keys v)] 414 | [(b) (test body 'body ) (set! body v)] 415 | [(ak) (test all-keys 'all-keys ) (set! all-keys v)] 416 | [(ok) (test other-keys 'other-keys) (set! other-keys v)] 417 | [else (raise-syntax-error #f "bad lambda formals" stx v)]) 418 | (loop state #'xs))]))] 419 | [v (loop state #'(&rest v))])) 420 | (set! vars (reverse vars)) 421 | (set! opts (map process-optional-arg (reverse opts))) 422 | (set! keys (map process-keyword-arg (reverse keys))) 423 | (when (and (or rest-keys body all-keys other-keys) (not rest)) 424 | (set! rest #'rest)) 425 | (cond 426 | ;; non-trivial case -- full processing 427 | [(or (pair? opts) (pair? keys) rest-keys body all-keys other-keys) 428 | (unless rest (set! rest #'rest)) 429 | ;; other-keys is computed from all-keys 430 | (when (and other-keys (not all-keys)) (set! all-keys #'all-keys)) 431 | (quasisyntax/loc stx 432 | (lambda (#,@vars . #,rest) 433 | (let*-values 434 | (#,@(map (lambda (o) 435 | #`[(#,(car o)) 436 | (if (pair? #,rest) 437 | (begin0 (car #,rest) 438 | (set! #,rest (cdr #,rest))) 439 | #,(cadr o))]) 440 | opts) 441 | #,@(map (lambda (k) 442 | #`[(#,(car k)) 443 | (getarg #,rest #,(cadr k) 444 | (lambda () #,(caddr k)))]) 445 | keys) 446 | #,@(if rest-keys 447 | #`([(#,rest-keys) 448 | (filter-out-keys '#,(map cadr keys) #,rest)]) 449 | #'()) 450 | #,@(cond 451 | ;; At most one scan for body, all-keys, other-keys. This 452 | ;; could be much shorter by always using keys/args, but a 453 | ;; function call is not a place to spend time on. 454 | [(and body all-keys) 455 | #`([(#,all-keys #,body) 456 | ;; inlined keys/args 457 | (let loop ([args #,rest] [keys '()]) 458 | (cond [(or (null? args) 459 | (null? (cdr args)) 460 | (not (keyword*? (car args)))) 461 | (values (reverse keys) args)] 462 | [else (loop (cddr args) 463 | (list* (cadr args) (car args) 464 | keys))]))])] 465 | [body 466 | #`([(#,body) 467 | (let loop ([args #,rest]) 468 | (if (or (null? args) 469 | (null? (cdr args)) 470 | (not (keyword*? (car args)))) 471 | args 472 | (loop (cddr args))))])] 473 | [all-keys 474 | #`([(#,all-keys) 475 | ;; inlined keys/args, not returning args 476 | (let loop ([args #,rest] [keys '()]) 477 | (cond [(or (null? args) 478 | (null? (cdr args)) 479 | (not (keyword*? (car args)))) 480 | (reverse keys)] 481 | [else (loop (cddr args) 482 | (list* (cadr args) (car args) 483 | keys))]))])] 484 | [else #'()]) 485 | #,@(if other-keys 486 | #`([(#,other-keys) ; use all-keys (see above) 487 | (filter-out-keys '#,(map cadr keys) #,all-keys)]) 488 | #'())) 489 | expr0 expr ...)))] 490 | ;; common cases: no optional, keyword, or other fancy stuff 491 | [(null? vars) 492 | (quasisyntax/loc stx 493 | (lambda #,(or rest #'()) expr0 expr ...))] 494 | [else 495 | (quasisyntax/loc stx 496 | (lambda (#,@vars . #,(or rest #'())) expr0 expr ...))]))])) 497 | 498 | ;; Keyword utilities 499 | (provide (rename keyword*? keyword?) syntax-keyword? 500 | (rename keyword->string* keyword->string) 501 | (rename string->keyword* string->keyword) 502 | ;; also provide the builtin as `real-keyword' 503 | (rename keyword? real-keyword?) 504 | (rename keyword->string real-keyword->string) 505 | (rename string->keyword string->real-keyword)) 506 | ;;>> (keyword? x) 507 | ;;> A predicate for keyword symbols (symbols that begin with a ":"). 508 | ;;> (Note: this is different from Racket's keywords!) 509 | (define (keyword*? x) 510 | (and (symbol? x) (not (eq? x '||)) 511 | (eq? (string-ref (symbol->string x) 0) #\:))) 512 | ;;>> (syntax-keyword? x) 513 | ;;> Similar to `keyword?' but also works for an identifier (a syntax 514 | ;;> object) that contains a keyword. 515 | (define (syntax-keyword? x) 516 | (keyword*? (if (syntax? x) (syntax-e x) x))) 517 | ;;>> (keyword->string k) 518 | ;;>> (string->keyword s) 519 | ;;> Convert a Swindle keyword to a string and back. 520 | (define (keyword->string* k) 521 | (if (keyword*? k) 522 | (substring (symbol->string k) 1) 523 | (raise-type-error 'keyword->string "keyword" k))) 524 | (define (string->keyword* s) 525 | (if (string? s) 526 | (string->symbol (string-append ":" s)) 527 | (raise-type-error 'string->keyword "string" s))) 528 | 529 | ;; Keyword searching utilities (note: no errors for odd length) 530 | (provide getarg syntax-getarg getargs keys/args filter-out-keys) 531 | ;;>> (getarg args keyword [not-found]) 532 | ;;> Searches the given list of arguments for a value matched with the 533 | ;;> given keyword. Similar to CL's `getf', except no error checking is 534 | ;;> done for an unbalanced list. In case no value is found, the optional 535 | ;;> default value can be used -- this can be either a thunk, a promise, or 536 | ;;> any other value that will be used as is. For a repeated keyword the 537 | ;;> leftmost occurrence is used. 538 | (define (getarg args keyword . not-found) 539 | (let loop ([args args]) 540 | (cond [(or (null? args) (null? (cdr args))) 541 | (and (pair? not-found) 542 | (let ([x (car not-found)]) 543 | (cond [(procedure? x) (x)] 544 | [(promise? x) (force x)] 545 | [else x])))] 546 | [(eq? (car args) keyword) (cadr args)] 547 | [else (loop (cddr args))]))) 548 | ;;>> (syntax-getarg syntax-args keyword [not-found]) 549 | ;;> Similar to `getarg' above, but the input is a syntax object of a 550 | ;;> keyword-value list. 551 | (define (syntax-getarg syntax-args keyword . not-found) 552 | (when (syntax? keyword) (set! keyword (syntax-e keyword))) 553 | (let loop ([args syntax-args]) 554 | (syntax-case args () 555 | [(key arg . more) 556 | (if (eq? (syntax-e #'key) keyword) #'arg (loop #'more))] 557 | [_ (and (pair? not-found) 558 | (let ([x (car not-found)]) 559 | (cond [(procedure? x) (x)] 560 | [(promise? x) (force x)] 561 | [else x])))]))) 562 | ;;>> (getargs initargs keyword) 563 | ;;> The same as `getarg' but return the list of all key values matched -- 564 | ;;> no need for a default value. The result is in the same order as in 565 | ;;> the input. 566 | (define (getargs initargs keyword) 567 | (define (scan tail) 568 | (cond [(null? tail) '()] 569 | [(null? (cdr tail)) (error 'getargs "keyword list not balanced.")] 570 | [(eq? (car tail) keyword) (cons (cadr tail) (scan (cddr tail)))] 571 | [else (scan (cddr tail))])) 572 | (scan initargs)) 573 | ;;>> (keys/args args) 574 | ;;> The given argument list is scanned and split at the point where there 575 | ;;> are no more keyword-values, and the two parts are returned as two 576 | ;;> values. 577 | ;;> => (keys/args '(:a 1 :b 2 3 4 5)) 578 | ;;> (:a 1 :b 2) 579 | ;;> (3 4 5) 580 | (define (keys/args args) 581 | (let loop ([args args] [keys '()]) 582 | (cond [(or (null? args) (null? (cdr args)) (not (keyword*? (car args)))) 583 | (values (reverse keys) args)] 584 | [else (loop (cddr args) (list* (cadr args) (car args) keys))]))) 585 | ;;>> (filter-out-keys outs args) 586 | ;;> The keywords specified in the outs argument, with their matching 587 | ;;> values are filtered out of the second arguments. 588 | (define (filter-out-keys outs args) 589 | (let loop ([as args] [r '()]) 590 | (cond [(null? as) (reverse r)] 591 | [(null? (cdr as)) (reverse (cons (car as) r))] 592 | [else 593 | (loop (cddr as) 594 | (if (memq (car as) outs) r (list* (cadr as) (car as) r)))]))) 595 | -------------------------------------------------------------------------------- /clos.rkt: -------------------------------------------------------------------------------- 1 | ;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org) 2 | 3 | ;;> This module contains only syntax definitions, which makes Swindle closer 4 | ;;> to CLOS -- making the object system much more convenient to use. 5 | 6 | #lang s-exp swindle/turbo 7 | 8 | (require swindle/tiny-clos) 9 | (provide (all-from swindle/tiny-clos)) 10 | 11 | ;;; --------------------------------------------------------------------------- 12 | ;;; General helpers 13 | 14 | (defsyntax (args-arity stx) 15 | (syntax-case stx () 16 | [(_ args) 17 | (let loop ([args #'args] [n 0]) 18 | (syntax-case args () 19 | [(a . more) 20 | (or (not (identifier? #'a)) 21 | ;; stop at &-keyword 22 | (let ([sym (syntax-e #'a)]) 23 | (or (eq? sym '||) 24 | (not (eq? #\& (string-ref (symbol->string sym) 0)))))) 25 | (loop #'more (add1 n))] 26 | [() (datum->syntax-object stx n stx)] 27 | [_ (quasisyntax/loc stx (make-arity-at-least #,n))]))])) 28 | 29 | ;;; --------------------------------------------------------------------------- 30 | ;;; Generic macros 31 | 32 | ;;>>... Generic macros 33 | 34 | ;;>> (generic) 35 | ;;> | (generic name initargs ...) 36 | ;;> | (generic name (arg ...) initargs ...) 37 | ;;> Create a generic function object (an instance of the 38 | ;;> `*default-generic-class*' parameter). The first form uses the default 39 | ;;> name given by the syntactical context, the second one gets an explicit 40 | ;;> name and the third also gets a list of arguments which is used to 41 | ;;> count the required number of arguments. If there is no argument list 42 | ;;> to count, the first method that gets added will set this number. The 43 | ;;> two last forms allow initargs to be passed to the instance 44 | ;;> creation, for example, to specify a `:combination' argument. (The 45 | ;;> first form does not allow keywords, since a keyword would be taken as 46 | ;;> the name.) 47 | (defsyntax* (generic stx) 48 | (syntax-case stx () 49 | [(_) 50 | #`(make (*default-generic-class*) :name '#,(syntax-local-name))] 51 | [(_ name) (identifier? #'name) 52 | #'(make (*default-generic-class*) :name 'name)] 53 | [(_ name initarg initargs ...) 54 | (and (identifier? #'name) (syntax-keyword? #'initarg)) 55 | #'(make (*default-generic-class*) initarg initargs ... :name 'name)] 56 | [(_ name args) (identifier? #'name) 57 | #`(make (*default-generic-class*) 58 | :name 'name :arity (args-arity args))] 59 | [(_ name args initarg initargs ...) 60 | (and (identifier? #'name) (syntax-keyword? #'initarg)) 61 | #`(make (*default-generic-class*) 62 | initarg initargs ... :name 'name :arity (args-arity args))])) 63 | 64 | ;;>> (defgeneric name (arg ...) initargs ...) 65 | ;;> | (defgeneric (name arg ...) initargs ...) 66 | ;;> | (defgeneric name initargs ...) 67 | ;;> This form defines a generic function using the `generic' syntax given 68 | ;;> above. The last form doesn't specify a number of arguments. Some 69 | ;;> extra `initargs' can be specified too but they are needed mainly for a 70 | ;;> `:combination' argument. 71 | (defsyntax* (defgeneric stx) 72 | (let* ([ctx (syntax-local-context)] 73 | [ctx (cond [(pair? ctx) (car ctx)] 74 | [(eq? ctx 'top-level) ctx] 75 | [else #f])] 76 | [mark (lambda (name) 77 | ((syntax-local-value #'generic-contexts-defined?) name ctx))]) 78 | (syntax-case stx () 79 | [(_ name args initargs ...) (identifier? #'name) 80 | (begin (mark #'name) #'(define name (generic name args initargs ...)))] 81 | [(_ (name . args) initargs ...) (identifier? #'name) 82 | (begin (mark #'name) #'(define name (generic name args initargs ...)))] 83 | [(_ name initargs ...) (identifier? #'name) 84 | (begin (mark #'name) #'(define name (generic name initargs ...)))]))) 85 | 86 | ;; returns #t if an identifier id in context ctx is already defined as a genric 87 | ;; (used by defmethod to detect when it should expand to an add-method) 88 | (define-syntax generic-contexts-defined? 89 | (let ([table (make-hash-table 'weak)]) 90 | (lambda (id ctx) 91 | ;; ctx is either the first element of (syntax-local-context) or 92 | ;; 'top-level. Note that top-level identifiers in different modules 93 | ;; should not be `module-identifier=?' (eg, `eval' takes care of this). 94 | (let ([cs (hash-table-get table ctx (lambda () '()))]) 95 | (or (ormap (lambda (c) (module-identifier=? id c)) cs) ; defined 96 | (begin (hash-table-put! table ctx (cons id cs)) ; undefined 97 | #f)))))) 98 | 99 | ;;; --------------------------------------------------------------------------- 100 | ;;; Method macros 101 | 102 | ;;>>... Method macros 103 | 104 | ;;>> (call-next-method [args ...]) [*local*] 105 | ;;>> (next-method?) [*local*] 106 | ;;> These are bindings which are available only in method bodies. 107 | ;;> `call-next-method' will invoke the next method in a generic invocation 108 | ;;> sequence if any. If arguments are given to `call-next-method', it 109 | ;;> will change the arguments for the next method -- but this is done when 110 | ;;> the methods are already filtered and sorted, so the new arguments 111 | ;;> should always be consistent with the old types. If there are no 112 | ;;> methods left, or when calling a method directly, or when a before or 113 | ;;> after method is used, the `no-next-method' generic will be used -- 114 | ;;> normally resulting in an error. `next-method?' returns `#t' if there 115 | ;;> is another method ready to be called. 116 | 117 | (defsyntax (make-method-specs/initargs stx) 118 | (syntax-case stx () 119 | [(_ name args0 body . more) 120 | (let loop ([args #'args0] [specializers '()] [arguments '()]) 121 | (syntax-case args (=) 122 | [([arg = val] . rest) 123 | (loop #'rest 124 | (cons #'(singleton val) specializers) (cons #'arg arguments))] 125 | [([arg type] . rest) 126 | (loop #'rest (cons #'type specializers) (cons #'arg arguments))] 127 | [([arg] . rest) 128 | (loop #'rest (cons #' specializers) (cons #'arg arguments))] 129 | [(arg . rest) 130 | (and (identifier? #'arg) 131 | ;; stop at &-keyword 132 | (let ([sym (syntax-e #'arg)]) 133 | (or (eq? sym '||) 134 | (not (eq? #\& (string-ref (symbol->string sym) 0)))))) 135 | (loop #'rest (cons #' specializers) (cons #'arg arguments))] 136 | [_ ; both null and rest argument 137 | (let* ([specializers (reverse specializers)] 138 | [arguments (reverse arguments)] 139 | [name-e (syntax-e #'name)] 140 | [cnm (datum->syntax-object 141 | #'args0 'call-next-method #'args0)]) 142 | (unless (null? (syntax-e args)) 143 | (set! arguments 144 | (if (null? arguments) args (append arguments args)))) 145 | (let ([makeit 146 | (quasisyntax/loc stx 147 | (make (*default-method-class*) 148 | :specializers (list #,@specializers) 149 | :name '#,(if name-e #'name (syntax-local-name)) 150 | :procedure 151 | (lambda (#,cnm . #,arguments) 152 | ;; See "Trick" in tiny-clos.rkt 153 | ;; -- use a syntax to not do this unless needed 154 | (letsyntax 155 | ([#,(datum->syntax-object 156 | #'args0 'next-method? #'args0) 157 | (lambda (stx) 158 | (syntax-case stx () 159 | [(__) #'(not (eq? '*no-next-method* 160 | (object-name #,cnm)))] 161 | [(__ . xs) 162 | #'((named-lambda next-method? () 1) 163 | . xs)] 164 | [__ 165 | #'(named-lambda next-method? () 166 | (not 167 | (eq? '*no-next-method* 168 | (object-name #,cnm))))]))]) 169 | . body)) 170 | . more))]) 171 | (if name-e 172 | (quasisyntax/loc stx (letrec ([name #,makeit]) name)) 173 | makeit)))]))])) 174 | 175 | ;;>> (method (arg ...) body ...) 176 | ;;>> (named-method name (arg ...) body ...) 177 | ;;>> (qualified-method qualifier (arg ...) body ...) 178 | ;;> These forms are all similar variants to create a method object (and 179 | ;;> instance of the `*default-method-class*' parameter). A method looks 180 | ;;> very similar to a lambda expression, except that the an argument can 181 | ;;> be a of the form `[arg spec]' where `spec' is a specializer -- either 182 | ;;> a class or a singleton specifier (the square brackets are equivalent 183 | ;;> to round parens, just make the code more readable). Also, an argument 184 | ;;> can have the form of `[arg = val]' which is shorthand for specifying 185 | ;;> `[arg (singleton val)]'. In case of a simple argument, is 186 | ;;> always used as a specializer, but this processing stops as soon as a 187 | ;;> &-keyword is encountered. The `named-method' form is used to provide 188 | ;;> an explicit name (which can be used to call itself recursively) , and 189 | ;;> `qualified-method' is used to provide an explicit qualifier (which 190 | ;;> should be one of the standard qualifiers (:primary, :around, :before, 191 | ;;> or :after) when using the standard and classes). 192 | ;;> 193 | ;;> The resulting method can be added to a generic and these specializers 194 | ;;> will be used when filtering applicable methods, or it can be used by 195 | ;;> itself and the specializers will be used to check the arguments. This 196 | ;;> makes it easy to use `method' instead of `lambda' to get some type 197 | ;;> information, but note that the result is going to run slower since the 198 | ;;> type check only takes time but cannot be used by Racket to optimize 199 | ;;> the code. 200 | ;;> 201 | ;;> Note that the specializer argument are evaluated normally, which means 202 | ;;> that anything can be used, even something like: 203 | ;;> (let ([x (list )]) 204 | ;;> (method ([x (2nd x)] [y = (+ 2 3)]) (+ x y))) 205 | (defsubst* (method args body0 body ...) 206 | (make-method-specs/initargs #f args (body0 body ...))) 207 | (defsubst* (named-method name args body0 body ...) 208 | (make-method-specs/initargs name args (body0 body ...))) 209 | (defsubst* (qualified-method qualifier args body0 body ...) 210 | (make-method-specs/initargs #f args (body0 body ...) :qualifier qualifier)) 211 | 212 | ;;>> (-defmethod-create-generics- [#t/#f]) 213 | ;;> This is a syntax parameter (see above) holding a boolean. When this 214 | ;;> is set to `#t' (the default), then the `defmethod' form below will try 215 | ;;> to detect when the first definition happens and automatic add a 216 | ;;> `defgeneric' form to define the object as a generic. A safer but less 217 | ;;> convenient approach would be to set this to `#f' and always do an 218 | ;;> explicit `defgeneric'. 219 | (define-syntax-parameter* -defmethod-create-generics- #t) 220 | 221 | (defsyntax (method-def-adder stx) 222 | (syntax-case stx () 223 | [(_ qualifier name args body ...) (identifier? #'name) 224 | ;; always make it with no name so add-method will add it 225 | (with-syntax ([method-make (syntax/loc stx 226 | (qualified-method qualifier args body ...))]) 227 | (let ([ctx (syntax-local-context)]) 228 | (cond 229 | [(or ; if: 230 | ;; not enabled 231 | (not (syntax-e ((syntax-local-value 232 | #'-defmethod-create-generics-)))) 233 | ;; expression position -- same as using add-method 234 | (eq? 'expression ctx) 235 | ;; defined symbol or second module binding 236 | (identifier-binding #'name) 237 | ;; already defined in this local context or top-level 238 | (let ([ctx (cond [(pair? ctx) (car ctx)] 239 | [(eq? ctx 'top-level) ctx] 240 | [else #f])]) 241 | (and ctx ((syntax-local-value #'generic-contexts-defined?) 242 | #'name ctx)))) 243 | ;; then use add-method 244 | ;; (printf ">>> ~s: add\n" (syntax-e #'name)) 245 | (syntax/loc stx (add-method name method-make))] 246 | ;; this might still be useful sometimes... 247 | ;; [(eq? 'top-level ctx) 248 | ;; ;; if top-level then use a trick: try to use an 249 | ;; (syntax/loc stx 250 | ;; (define name ; trick: try using exising generic 251 | ;; (let ([g (or (no-errors name) (generic name))]) 252 | ;; (add-method g method-make) 253 | ;; g)))] 254 | [else 255 | ;; first module or function binding 256 | ;; (printf ">>> ~s: def\n" (syntax-e #'name)) 257 | (syntax/loc stx (define name 258 | (let ([g (generic name)]) 259 | (add-method g method-make) 260 | g)))])))])) 261 | 262 | ;;>> (defmethod name [qualifier] (arg ...) body ...) 263 | ;;> | (defmethod [qualifier] (name arg ...) body ...) 264 | ;;> This form is used to define a method object using `method' and its 265 | ;;> variants above. A qualifier (a :keyword) can be specified anywhere 266 | ;;> before the argument list, and the name can be either specified before 267 | ;;> the arguments (Lisp style) or with the arguments (Scheme style). 268 | ;;> Depending on `-defmethod-create-generics-' (see above), this form 269 | ;;> might add a `defgeneric' form to define the given `name' as a generic 270 | ;;> object, and then add the created method. The created method is 271 | ;;> attached to the generic in any case, which makes the name of this form 272 | ;;> a little misleading since it is not always defining a variable value. 273 | ;;> In a local definition context, this should do the right thing as long 274 | ;;> as `defmethod' or `defgeneric' is used to define the method (but note 275 | ;;> that using a local generic function, is very inefficient) -- for 276 | ;;> example, both of these work (defining a local generic): 277 | ;;> (define (f) 278 | ;;> (defgeneric foo) 279 | ;;> (defmethod (foo [x ]) 1) 280 | ;;> (defmethod (foo [x ]) 2) 281 | ;;> 3) 282 | ;;> (define (f) 283 | ;;> (defmethod (foo [x ]) 1) 284 | ;;> (defmethod (foo [x ]) 2) 285 | ;;> 3) 286 | ;;> but this fails because the first `defmethod' doesn't know that it is 287 | ;;> already defined: 288 | ;;> (define (f) 289 | ;;> (define foo (generic foo)) 290 | ;;> (defmethod (foo [x c1]) 1) 291 | ;;> (defmethod (foo [x c1]) 2) 292 | ;;> 3) 293 | ;;> second "but" -- this: 294 | ;;> (define (f) 295 | ;;> (define foo (generic foo)) 296 | ;;> blah 297 | ;;> (defmethod (foo [x ]) 1) 298 | ;;> (defmethod (foo [x ]) 2) 299 | ;;> 3) 300 | ;;> works because a `defmethod' in an expression context is always the 301 | ;;> same as `add-method'. 302 | (defsyntax* (defmethod stx) 303 | (define (n+a? stx) 304 | (let ([na (syntax-e stx)]) (and (pair? na) (identifier? (car na))))) 305 | (syntax-case stx () 306 | [(_ name qualifier args body0 body ...) 307 | (and (identifier? #'name) (syntax-keyword? #'qualifier)) 308 | (syntax/loc stx 309 | (method-def-adder qualifier name args body0 body ...))] 310 | [(_ qualifier name args body0 body ...) 311 | (and (identifier? #'name) (syntax-keyword? #'qualifier)) 312 | (syntax/loc stx 313 | (method-def-adder qualifier name args body0 body ...))] 314 | [(_ qualifier name+args body0 body ...) 315 | (and (n+a? #'name+args) (syntax-keyword? #'qualifier)) 316 | ;; simple pattern matching with (name . args) and using args won't work 317 | ;; since the destructing loses the arguments context and call-next-method 318 | ;; won't be accessible in the body. 319 | (with-syntax ([name (car (syntax-e #'name+args))] 320 | [args (datum->syntax-object ; hack binding context! 321 | #'name+args 322 | (cdr (syntax-e #'name+args)) 323 | #'name+args)]) 324 | (syntax/loc stx 325 | (method-def-adder qualifier name args body0 body ...)))] 326 | [(_ name+args body0 body ...) (n+a? #'name+args) 327 | ;; same as above 328 | (with-syntax ([name (car (syntax-e #'name+args))] 329 | [args (datum->syntax-object ; hack binding context! 330 | #'name+args 331 | (cdr (syntax-e #'name+args)) 332 | #'name+args)]) 333 | (syntax/loc stx 334 | (method-def-adder #f name args body0 body ...)))] 335 | [(_ name args body0 body ...) (identifier? #'name) 336 | (syntax/loc stx (method-def-adder #f name args body0 body ...))])) 337 | 338 | ;;>> (beforemethod ...) 339 | ;;>> (aftermethod ...) 340 | ;;>> (aroundmethod ...) 341 | ;;>> (defbeforemethod ...) 342 | ;;>> (defaftermethod ...) 343 | ;;>> (defaroundmethod ...) 344 | ;;> These forms are shorthands that will generate a qualified method using 345 | ;;> one of the standard qualifiers. 346 | (defsubst* (beforemethod . more) (qualified-method :before . more)) 347 | (defsubst* (aftermethod . more) (qualified-method :after . more)) 348 | (defsubst* (aroundmethod . more) (qualified-method :around . more)) 349 | (defsubst* (defbeforemethod . more) (defmethod :before . more)) 350 | (defsubst* (defaftermethod . more) (defmethod :after . more)) 351 | (defsubst* (defaroundmethod . more) (defmethod :around . more)) 352 | 353 | ;;; --------------------------------------------------------------------------- 354 | ;;; Class macros 355 | 356 | ;;>>... Class macros 357 | 358 | (defsyntax (make-class-form stx) 359 | (define (slots/initargs s/a) 360 | (let loop ([xs s/a] [r '()]) 361 | (syntax-case xs () 362 | [() (values (datum->syntax-object #'s/a (reverse r) #'s/a) 363 | #'())] 364 | [((name . args) . more) (identifier? #'name) 365 | (loop #'more (cons #'(list 'name . args) r))] 366 | [(key val . more) (syntax-keyword? #'key) 367 | (values (datum->syntax-object #'s/a (reverse r) #'s/a) 368 | #'(key val . more))] 369 | [(name . more) (identifier? #'name) 370 | (loop #'more (cons #'(list 'name) r))]))) 371 | (syntax-case stx () 372 | [(_ metaclass cname supers . s/a) 373 | (let*-values ([(slots initargs) (slots/initargs #'s/a)] 374 | [(meta) (syntax-getarg initargs :metaclass #'metaclass)]) 375 | (with-syntax ([(arg ...) #`(#,@initargs 376 | :direct-supers (list . supers) 377 | :direct-slots (list #,@slots) 378 | :name '#,(if (syntax-e #'cname) 379 | #'cname (syntax-local-name)))]) 380 | (if (identifier? #'cname) 381 | #`(rec-make (cname #,meta arg ...)) 382 | #`(make #,meta arg ...))))])) 383 | 384 | ;;>> (class [name] (super ...) slot ... class-initarg ...) 385 | ;;> Create a class object (an instance of the `*default-class-class*' 386 | ;;> parameter). An explicit name can optionally be specified explicitly. 387 | ;;> The list of superclasses are evaluated normally, so they can be any 388 | ;;> expression (as with the `method' forms). Each slot can be either a 389 | ;;> symbol, which will be used as the slot name, or a list that begins 390 | ;;> with a symbol and continues with a keyword-argument option list. 391 | ;;> Finally, more initargs for the class generation can be provided. See 392 | ;;> the `defclass' forms below for an explanation on the available slot 393 | ;;> option and class initargs. If a name is given, then `rec-make' is 394 | ;;> used, see that for a description. 395 | (defsyntax* (class stx) 396 | (syntax-case stx () 397 | [(_ name supers slot ...) (identifier? #'name) 398 | #'(make-class-form (*default-class-class*) name supers slot ...)] 399 | [(_ supers slot ...) 400 | #'(make-class-form (*default-class-class*) #f supers slot ...)])) 401 | 402 | ;;>> (entityclass [name] (super) slot ... class-initarg ...) 403 | ;;> Same as the `class' form, but creates an entity class object (an 404 | ;;> instance of the `*default-entityclass-class*' parameter). 405 | (defsyntax* (entityclass stx) 406 | (syntax-case stx () 407 | [(_ name supers slot ...) (identifier? #'name) 408 | #'(make-class-form (*default-entityclass-class*) name supers slot ...)] 409 | [(_ supers slot ...) 410 | #'(make-class-form (*default-entityclass-class*) #f supers slot ...)])) 411 | 412 | ;;>> (-defclass-auto-initargs- [#f/initargs]) 413 | ;;> This is a syntax parameter (see above) holding either `#f' or an 414 | ;;> initargs list . If it is not `#f', `defclass' below will add its 415 | ;;> contents to the end of the given initargs (so user supplied arguments 416 | ;;> can override them). The default is `#f'. 417 | (define-syntax-parameter* -defclass-auto-initargs- #f) 418 | 419 | ;;>> (-defclass-autoaccessors-naming- [naming-keyword]) 420 | ;;> This syntax parameter holds a keyword symbol that is used in the 421 | ;;> `defclass' for the `:autoaccessors' if it is specified as `#t' or if 422 | ;;> it used due to `:auto'. See the description of the `:autoaccessors' 423 | ;;> option below for possible values. The default is `:class-slot'. 424 | (define-syntax-parameter* -defclass-autoaccessors-naming- :class-slot) 425 | 426 | ;;>> (-defclass-accessor-mode- [mode-keyword]) 427 | ;;> This syntax parameter holds a keyword symbol that is used in the 428 | ;;> `defclass' for the way accessors, readers, and writers are generated. 429 | ;;> It can be `:defmethod' for using `defmethod', `:defgeneric' for using 430 | ;;> `defgeneric' and then `add-method', `:add-method' for using 431 | ;;> `add-method', `:method' for defining an independent method, or 432 | ;;> `:procedure' for defining a simple Scheme procedure. The default is 433 | ;;> `:defmethod. This default is usually fine, but a situation where this 434 | ;;> is important is if the syntax parameter `-defmethod-create-generics-' 435 | ;;> is set to `#f' so a `defmethod' requires a prior `defgeneric' so a 436 | ;;> defclass will not work unless the generic functions are defined in 437 | ;;> advance. 438 | (define-syntax-parameter* -defclass-accessor-mode- :defmethod) 439 | 440 | ;;>> (defclass name (super ...) slot ... class-initarg ...) 441 | ;;> This form uses the `class' form above to define a new class. See the 442 | ;;> `class' form for the syntax. Note that slot-options that are not 443 | ;;> compile-time ones (method names) are accumulated according to the 444 | ;;> class precedence list. 445 | ;;> 446 | ;;> Available slot options are: 447 | ;;> * :initarg keyword 448 | ;;> Use `keyword' in `make' to provide a value for this slot. 449 | ;;> * :initializer func 450 | ;;> Use the given function to initialize the slot -- either a thunk or a 451 | ;;> function that will be applied on the initargs given to `make'. 452 | ;;> * :initvalue value 453 | ;;> Use `value' as the default for this slot. 454 | ;;> * :reader name 455 | ;;> Define `name' (an unquoted symbol) as a reader method for this slot. 456 | ;;> * :writer name 457 | ;;> Define `name' (an unquoted symbol) as a writer method for this slot. 458 | ;;> * :accessor name 459 | ;;> Define `name' (an unquoted symbol) as an accessor method for this 460 | ;;> slot -- this means that two methods are defined: `name' and 461 | ;;> `set-name!'. 462 | ;;> * :type type 463 | ;;> Restrict this slot value to objects of the given `type'. 464 | ;;> * :lock { #t | #f | value } 465 | ;;> If specified and non-`#f', then this slot is locked. `#t' locks it 466 | ;;> permanently, but a different value works as a key: they allow setting 467 | ;;> the slot by using cons of the key and the value to set. 468 | ;;> * :allocation { :class | :instance } 469 | ;;> Specify that this slot is a normal one (`:instance', the default), 470 | ;;> or allocated per class (`:class'). 471 | ;;> The specific way of creating helper methods (for readers, writers, and 472 | ;;> accessors) is determined by `-defclass-accessor-mode-' (see above). 473 | ;;> 474 | ;;> Available class options (in addition to normal ones that initialize 475 | ;;> the class slots like `:name', `:direct-slots', `:direct-supers') are: 476 | ;;> * :metaclass class 477 | ;;> create a class object which is an instance of the `class' 478 | ;;> meta-class (this means that an instance of the given meta-class 479 | ;;> should be used for creating the new class). 480 | ;;> * :autoinitargs { #t | #f } 481 | ;;> if set to `#t', make the class definition automatically generate 482 | ;;> initarg keywords from the slot names. (The keywords have the same 483 | ;;> name as the slots, eg `:foo'.) 484 | ;;> * :autoaccessors { #f | #t | :class-slot | :slot } 485 | ;;> if set to non-`#f', generate accessor methods automatically -- 486 | ;;> either using the classname "-" slotname convention (`:class-slot') 487 | ;;> or just the slotname (`:slot'). If it is `#t' (or turned on by 488 | ;;> `:auto') then the default naming style is taken from the 489 | ;;> `-defclass-autoaccessors-naming-' syntax parameter. Note that for 490 | ;;> this, and other external object definitions (`:automaker' and 491 | ;;> `:autopred'), the class name is stripped of a surrounding "<>"s if 492 | ;;> any. 493 | ;;> * :automaker { #f | #t } 494 | ;;> automatically creates a `maker' function using the "make-" classname 495 | ;;> naming convention. The maker function is applied on arguments and 496 | ;;> keyword-values -- if there are n slots, then arguments after the 497 | ;;> first n are passed to `make' to create the instance, then the first 498 | ;;> n are `slot-set!'ed into the n slots. This means that it can get 499 | ;;> any number of arguments, and usually there is no point in additional 500 | ;;> keyword values (since if they initialize slots, their values will 501 | ;;> get overridden anyway). It also means that the order of the 502 | ;;> arguments depend on the *complete* list of the class's slots (as 503 | ;;> given by `class-slots'), so use caution when doing multiple 504 | ;;> inheritance (actually, in that case it is probably better to avoid 505 | ;;> these makers anyway). 506 | ;;> * :autopred { #f | #t } 507 | ;;> automatically create a predicate function using the `classname "?"' 508 | ;;> naming convention. 509 | ;;> * :default-slot-options { #f | '(keyword ...) } 510 | ;;> if specified as a quoted list, then slot descriptions are modified 511 | ;;> so the first arguments are taken as values to the specified 512 | ;;> keywords. For example, if it is `'(:type :initvalue)' then a slot 513 | ;;> description can have a single argument for `:type' after the slot 514 | ;;> name, a second argument for `:initvalue', and the rest can be more 515 | ;;> standard keyword-values. This is best set with 516 | ;;> `-defclass-auto-initargs-' 517 | ;;> * :auto { #f | #t } 518 | ;;> if specified as `#t', then all automatic behavior available above is 519 | ;;> turned on. 520 | ;; The following option is added in extra.rkt 521 | ;;> * :printer { #f | #t | procedure } 522 | ;;> if given, install a printer function. `#t' means install the 523 | ;;> `print-object-with-slots' function from "clos.rkt", otherwise, it is 524 | ;;> expected to be a function that gets an object, an escape boolean 525 | ;;> flag an an optional port (i.e, 2 or more arguments), and prints the 526 | ;;> object on the class using the escape flag to select `display'-style 527 | ;;> (`#f') or `write'-style (#t). 528 | ;;> 529 | ;;> Note that the class object is made by `class' with a name, so it is 530 | ;;> possible to use the class itself as the value of `:type' properties 531 | ;;> for a recursive class. 532 | ;;> 533 | ;;> Whenever the classname is used, it is taken from the defined name, 534 | ;;> without a surrounding "<>"s if any. Note that some of these options 535 | ;;> are processed at compile time (all method names and auto-generation of 536 | ;;> methods). 537 | (defsyntax (make-defclass-form stx) 538 | (syntax-case stx () 539 | [(_ class-maker name supers . slots0) 540 | (identifier? #'name) 541 | (let loop ([slots1 #'slots0] [slots2 '()]) 542 | (syntax-case slots1 () 543 | [(slot more ...) (not (syntax-keyword? #'slot)) 544 | (loop #'(more ...) (cons #'slot slots2))] 545 | [(initarg ...) ; if slots1 is not null then it contains class keywords 546 | (let* ([autoargs (let ([as ((syntax-local-value 547 | #'-defclass-auto-initargs-))]) 548 | (and (syntax? as) (syntax-e as) as))] 549 | [initargs (if autoargs 550 | #`(initarg ... #,@autoargs) #'(initarg ...))] 551 | [defmethods '()] 552 | [sgetarg (lambda (arg . def) 553 | (let ([a (apply syntax-getarg initargs arg def)]) 554 | (if (syntax? a) (syntax-object->datum a) a)))] 555 | [all-auto (sgetarg :auto)] 556 | [autoaccessors (sgetarg :autoaccessors (and all-auto #t))] 557 | [automaker (or (sgetarg :automaker) all-auto)] 558 | [autopred (or (sgetarg :autopred) all-auto)] 559 | [accessor-mode (syntax-e ((syntax-local-value 560 | #'-defclass-accessor-mode-)))] 561 | [default-slot-options (sgetarg :default-slot-options)] 562 | [string-name 563 | (regexp-replace 564 | #rx"^<(.*)>$" (symbol->string (syntax-e #'name)) "\\1")]) 565 | (define (get-defaccessor-form a-name typed-args untyped-args body) 566 | (case accessor-mode 567 | [(:defmethod) 568 | #`(defmethod (#,a-name #,@typed-args) #,body)] 569 | [(:defgeneric) 570 | #`(begin (defgeneric (#,a-name #,@untyped-args)) 571 | (add-method #,a-name (method #,typed-args #,body)))] 572 | [(:add-method) 573 | #`(add-method #,a-name (method #,typed-args #,body))] 574 | [(:method) #`(define #,a-name (method #,typed-args #,body))] 575 | [(:procedure) #`(define (#,a-name #,@untyped-args) #,body)] 576 | [else (error 577 | 'defclass 578 | "bad value in -defclass-accessor-mode-: ~e" 579 | accessor-mode)])) 580 | (define (addreader reader sname) 581 | (push! (get-defaccessor-form 582 | reader #'((x name)) #'(x) #`(slot-ref x '#,sname)) 583 | defmethods)) 584 | (define (addwriter writer sname type) 585 | (push! (get-defaccessor-form 586 | writer #`((x name) #,(if type #`(n #,type) #'n)) #'(x n) 587 | #`(slot-set! x '#,sname n)) 588 | defmethods)) 589 | (define (do-slot slot) 590 | (define-values (sname args) 591 | (syntax-case slot () 592 | [(sname args ...) 593 | (values 594 | #'sname 595 | (cond 596 | [(not default-slot-options) #'(args ...)] 597 | [(and (list? default-slot-options) 598 | (= 2 (length default-slot-options)) 599 | (memq (car default-slot-options) 600 | '(quote quasiquote))) 601 | (let loop ([d (cadr default-slot-options)] 602 | [as #'(args ...)] 603 | [r '()]) 604 | (syntax-case as () 605 | [(v rest ...) (pair? d) 606 | (loop (cdr d) 607 | #'(rest ...) 608 | (list* #'v (car d) r))] 609 | [_ (datum->syntax-object #'(args ...) 610 | (append (reverse r) as) 611 | #'(args ...))]))] 612 | [else (raise-syntax-error 613 | #f "bad form for :default-slot-options" 614 | stx initargs)]))] 615 | [sname (values #'sname #'())])) 616 | (let ([reader (syntax-getarg args :reader)] 617 | [writer (syntax-getarg args :writer)] 618 | [accessor 619 | (syntax-getarg 620 | args :accessor 621 | (and autoaccessors 622 | (thunk 623 | (if (eq? autoaccessors :slot) 624 | sname 625 | (datum->syntax-object 626 | sname 627 | (string->symbol 628 | (concat string-name "-" 629 | (symbol->string (syntax-e sname)))) 630 | sname)))))] 631 | [type (syntax-getarg args :type)]) 632 | (when reader (addreader reader sname)) 633 | (when writer (addwriter writer sname type)) 634 | (when accessor 635 | (addreader accessor sname) 636 | (addwriter 637 | (datum->syntax-object 638 | accessor 639 | (string->symbol 640 | (concat "set-" (symbol->string (syntax-e accessor)) "!")) 641 | accessor) 642 | sname type)) 643 | (let loop ([as args] [res (list sname)]) 644 | (syntax-case as () 645 | [(keyword value more ...) 646 | (loop #'(more ...) 647 | (list* (if (memq (syntax-e #'keyword) 648 | '(:reader :writer :accessor)) 649 | #''value #'value) 650 | #'keyword res))] 651 | [() (datum->syntax-object as (reverse res) as)])))) 652 | (when (eq? autoaccessors #t) 653 | (set! autoaccessors 654 | (syntax-e ((syntax-local-value 655 | #'-defclass-autoaccessors-naming-))))) 656 | (unless (memq autoaccessors '(#t #f :slot :class-slot)) 657 | (raise-syntax-error 658 | #f (concat "`:autoaccessors' expecting either a " 659 | "`:slot' or `:class-slot' as value.") 660 | stx initargs)) 661 | (let ([slots (map do-slot (reverse slots2))]) 662 | #`(begin 663 | (define name 664 | (class-maker name supers 665 | . #,(datum->syntax-object 666 | #'slots0 667 | ;; note: append with a non-list 2nd arg 668 | (append 669 | slots (if all-auto 670 | #`(:autoinitargs #t #,@initargs) 671 | initargs)) 672 | #'slots0))) 673 | #,@(datum->syntax-object 674 | #'stx (reverse defmethods) #'stx) 675 | #,@(if automaker 676 | (with-syntax 677 | ([maker (datum->syntax-object 678 | #'name 679 | (string->symbol 680 | (concat "make-" string-name)) 681 | #'name)]) 682 | #'((define maker 683 | (let ([slots (class-slots name)]) 684 | (lambda args 685 | (let loop ([as args] [ss slots] [r '()]) 686 | (if (or (null? as) (null? ss)) 687 | (let ([new (make name . as)]) 688 | (for-each (lambda (x) 689 | (slot-set! new . x)) 690 | r) 691 | new) 692 | (loop (cdr as) (cdr ss) 693 | (cons (list (caar ss) (car as)) 694 | r))))))))) 695 | '()) 696 | #,@(if autopred 697 | (with-syntax 698 | ([pred? (datum->syntax-object 699 | #'name 700 | (string->symbol (concat string-name "?")) 701 | #'name)]) 702 | #'((define (pred? x) (instance-of? x name)))) 703 | '()))))]))])) 704 | 705 | (defsubst* (defclass name supers slot ...) 706 | (make-defclass-form class name supers slot ...)) 707 | 708 | ;;>> (defentityclass name (super ...) slot ... class-initarg ...) 709 | ;;> The same as `defclass', but for entity classes. 710 | (defsubst* (defentityclass name supers slot ...) 711 | (make-defclass-form entityclass name supers slot ...)) 712 | 713 | ;;; --------------------------------------------------------------------------- 714 | ;;; Forms with a provide version 715 | 716 | ;;>>... 717 | ;;> *** Auto provide forms 718 | 719 | ;;>> (defgeneric* ...) 720 | ;;>> (defclass* ...) 721 | ;;>> (defentityclass* ...) 722 | ;;> These forms are defined as the original version, except that the 723 | ;;> defined variable is automatically provided (made using 724 | ;;> `make-provide-syntax' above). Note that there is no version for 725 | ;;> `defmethod' since it should not be used where a single definition 726 | ;;> place is needed -- and it wouldn't make sense to have multiple 727 | ;;> `provide' forms for every `defmethod*' occurrence. Note that 728 | ;;> `defclass*' provides only the class identifier and not any 729 | ;;> automatically generated ones (accessors etc). 730 | (provide defgeneric*) (make-provide-syntax defgeneric defgeneric*) 731 | (provide defclass*) (make-provide-syntax defclass defclass*) 732 | (provide defentityclass*) (make-provide-syntax defentityclass defentityclass*) 733 | -------------------------------------------------------------------------------- /extra.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp swindle/turbo 2 | 3 | ;;> This module defines some additional useful functionality which requires 4 | ;;> Swindle. 5 | 6 | (require swindle/clos) 7 | 8 | ;;; --------------------------------------------------------------------------- 9 | ;;; A convenient `defstruct' 10 | 11 | ;; This makes it possible to create Racket structs using Swindle's `make' and 12 | ;; keyword arguments. 13 | 14 | (define struct-to-slot-names (make-hash-table)) 15 | 16 | (hash-table-put! struct-to-slot-names '()) 17 | 18 | (add-method initialize (method ([s ] initargs) ???)) 19 | 20 | (define (struct-type->class* stype maker slots) 21 | (let* ([this (struct-type->class stype)] 22 | [superslots (let ([s (class-direct-supers this)]) 23 | (and (pair? s) (null? (cdr s)) 24 | (hash-table-get 25 | struct-to-slot-names (car s) (thunk #f))))]) 26 | (when superslots 27 | (when (some (lambda (x) (memq x superslots)) slots) 28 | (error 'defstruct "cannot redefine slot names")) 29 | (let ([allslots (append superslots slots)]) 30 | (hash-table-put! struct-to-slot-names this slots) 31 | (add-method allocate-instance 32 | (let ([???s (build-list (length allslots) (lambda _ ???))]) 33 | (method ([class = this] initargs) (maker . ???s)))) 34 | (add-method initialize 35 | (let ([none "-"] 36 | [keys (build-list 37 | (length slots) 38 | (lambda (n) (list (symbol-append ': (nth slots n)) n)))] 39 | [setter! (5th (call-with-values 40 | (thunk (struct-type-info stype)) 41 | list))]) 42 | (method ([obj this] initargs) 43 | (for-each (lambda (k) 44 | (let ([v (getarg initargs (1st k) none)]) 45 | (unless (eq? none v) 46 | (setter! obj (2nd k) v)))) 47 | keys) 48 | (call-next-method)))))) 49 | this)) 50 | 51 | ;;>> (defstruct ([super]) slot ...) 52 | ;;> This is just a Swindle-style syntax for one of 53 | ;;> (define-struct struct-name (slot ...) (make-inspector)) 54 | ;;> (define-struct (struct-name super) (slot ...) (make-inspector)) 55 | ;;> with an additional binding of to the Swindle class that 56 | ;;> is computed by `struct-type->class'. The `(make-inspector)' is needed 57 | ;;> to make this a struct that we can access information on. Note that in 58 | ;;> method specifiers, the `struct:foo' which is defined by 59 | ;;> `define-struct' can be used just like `'. What all this means is 60 | ;;> that you can use Racket structs if you just want Swindle's generic 61 | ;;> functions, but use built in structs that are more efficient since they 62 | ;;> are part of the implementation. For example: 63 | ;;> 64 | ;;> => (defstruct () x y) 65 | ;;> => 66 | ;;> # 67 | ;;> => (defmethod (bar [x ]) (foo-x x)) 68 | ;;> => (bar (make-foo 1 2)) 69 | ;;> 1 70 | ;;> => (defmethod (bar [x struct:foo]) (foo-x x)) 71 | ;;> => (bar (make-foo 3 4)) 72 | ;;> 3 73 | ;;> => (generic-methods bar) 74 | ;;> (#) 75 | ;;> => (defstruct (foo) z) 76 | ;;> => (bar (make-foo2 10 11 12)) 77 | ;;> 10 78 | ;;> 79 | ;;> To make things even easier, the super-struct can be written using a 80 | ;;> "<...>" syntax which will be stripped, and appropriate methods are 81 | ;;> added to `allocate-instance' and `initialize' so structs can be built 82 | ;;> using keywords: 83 | ;;> 84 | ;;> => (defstruct () z) 85 | ;;> => (foo-x (make :z 3 :y 2 :x 1)) 86 | ;;> 1 87 | ;;> => (foo3-z (make :z 3 :y 2 :x 2)) 88 | ;;> 3 89 | ;;> 90 | ;;> The `' identifier *must* be of this form -- enclosed in 91 | ;;> "<>"s. This restriction is due to the fact that defining a Racket 92 | ;;> struct `foo', makes `foo' bound as a syntax object to something that 93 | ;;> cannot be used in any other way. 94 | (defsyntax* (defstruct stx) 95 | (define <>-re #rx"^<(.*)>$") 96 | (define (<>-id? id) 97 | (and (identifier? id) 98 | (regexp-match? <>-re (symbol->string (syntax-e id))))) 99 | (define (doit name super slots) 100 | (let* ([str (regexp-replace <>-re (symbol->string (syntax-e name)) "\\1")] 101 | [name-sans-<> (datum->syntax-object name (string->symbol str) name)] 102 | [struct:name (datum->syntax-object 103 | name (string->symbol (concat "struct:" str)) name)] 104 | [make-struct (datum->syntax-object 105 | name (string->symbol (concat "make-" str)) name)] 106 | [super (and super (datum->syntax-object 107 | super (string->symbol 108 | (regexp-replace 109 | <>-re (symbol->string (syntax-e super)) 110 | "\\1")) 111 | super))]) 112 | (quasisyntax/loc stx 113 | (begin 114 | (define-struct #,(if super #`(#,name-sans-<> #,super) name-sans-<>) 115 | #,slots (make-inspector)) 116 | (define #,name 117 | (struct-type->class* #,struct:name #,make-struct '#,slots)))))) 118 | (syntax-case stx () 119 | [(_ name (s) slot ...) (<>-id? #'name) (doit #'name #'s #'(slot ...))] 120 | [(_ name ( ) slot ...) (<>-id? #'name) (doit #'name #f #'(slot ...))] 121 | [(_ name more ...) (not (<>-id? #'name)) 122 | (raise-syntax-error #f "requires a name that looks like \"<...>\"" 123 | stx #'name)])) 124 | 125 | ;;; --------------------------------------------------------------------------- 126 | ;;; Convenient macros 127 | 128 | (defsyntax process-with-slots 129 | (syntax-rules () 130 | [(_ obj () (bind ...) body ...) 131 | (letsubst (bind ...) body ...)] 132 | [(_ obj ((id slot) slots ...) (bind ...) body ...) 133 | (process-with-slots 134 | obj (slots ...) (bind ... (id (slot-ref obj slot))) body ...)] 135 | [(_ obj (id slots ...) (bind ...) body ...) 136 | (process-with-slots 137 | obj (slots ...) (bind ... (id (slot-ref obj 'id))) body ...)])) 138 | 139 | ;;>> (with-slots obj (slot ...) body ...) 140 | ;;> Evaluate the body in an environment where each `slot' is defined as a 141 | ;;> symbol-macro that accesses the corresponding slot value of `obj'. 142 | ;;> Each `slot' is either an identifier `id' which makes it stand for 143 | ;;> `(slot-ref obj 'id)', or `(id slot)' which makes `id' stand for 144 | ;;> `(slot-ref obj slot)'. 145 | (defsubst* (with-slots obj (slot ...) body0 body ...) 146 | (process-with-slots obj (slot ...) () body0 body ...)) 147 | 148 | (defsyntax process-with-accessors 149 | (syntax-rules () 150 | [(_ obj () (bind ...) body ...) 151 | (letsubst (bind ...) body ...)] 152 | [(_ obj ((id acc) accs ...) (bind ...) body ...) 153 | (process-with-accessors 154 | obj (accs ...) (bind ... (id (acc obj))) body ...)] 155 | [(_ obj (id accs ...) (bind ...) body ...) 156 | (process-with-accessors 157 | obj (accs ...) (bind ... (id (id obj))) body ...)])) 158 | 159 | ;;>> (with-accessors obj (accessor ...) body ...) 160 | ;;> Evaluate the body in an environment where each `accessor' is defined 161 | ;;> as a symbol-macro that accesses `obj'. Each `accessor' is either an 162 | ;;> identifier `id' which makes it stand for `(id obj)', or 163 | ;;> `(id accessor)' which makes `id' stand for `(accessor obj);. 164 | (defsubst* (with-accessors obj (acc ...) body0 body ...) 165 | (process-with-accessors obj (acc ...) () body0 body ...)) 166 | 167 | ;;; --------------------------------------------------------------------------- 168 | ;;; An "as" conversion operator. 169 | 170 | ;;>> (as class obj) 171 | ;;> Converts `obj' to an instance of `class'. This is a convenient 172 | ;;> generic wrapper around Scheme conversion functions (functions that 173 | ;;> look like `foo->bar'), but can be used for other classes too. 174 | (defgeneric* as (class object)) 175 | 176 | (defmethod (as [c ] [x ]) 177 | (if (instance-of? x c) 178 | x 179 | (error 'as "can't convert ~e -> ~e; given: ~e." (class-of x) c x))) 180 | 181 | ;;>> (add-as-method from-class to-class op ...) 182 | ;;> Adds a method to `as' that will use the function `op' to convert 183 | ;;> instances of `from-class' to instances of `to-class'. More operators 184 | ;;> can be used which will make this use their composition. This is used 185 | ;;> to initialize `as' with the standard Scheme conversion functions. 186 | (define* (add-as-method from to . op) 187 | (let ([op (apply compose op)]) 188 | (add-method as (method ([c = to] [x from]) (op x))))) 189 | 190 | ;; Add Scheme primitives. 191 | (for-each 192 | (lambda (args) 193 | (apply (lambda (from to . ops) 194 | (add-as-method from to . ops) 195 | (let ([from* (cond [(eq? from ) ] 196 | [(eq? from ) ] 197 | [else #f])]) 198 | (when from* (add-as-method from* to . ops)))) 199 | args)) 200 | `((, , ,string-copy) 201 | (, , ,string->immutable-string) 202 | (, , ,string->symbol) 203 | (, , ,symbol->string) 204 | (, , ,string->keyword) 205 | (, , ,keyword->string) 206 | (, , ,exact->inexact) 207 | (, , ,inexact->exact) 208 | (, , ,number->string) 209 | (, , ,string->number) 210 | (, , ,string) 211 | (, , ,char->integer) 212 | (, , ,integer->char) 213 | (, , ,string->list) 214 | (, , ,list->string) 215 | (, , ,vector->list) 216 | (, , ,list->vector) 217 | (, , ,inexact->exact ,round) 218 | (, , ,inexact->exact ,round) 219 | (, , ,struct->vector) 220 | (, , ,regexp) 221 | (, , ,object-name) 222 | (, , ,bytes-copy) 223 | (, , ,bytes->immutable-bytes) 224 | (, , ,bytes->list) 225 | (, , ,list->bytes) 226 | (, , ,byte-regexp) 227 | (, , ,object-name) 228 | (, , ,string->bytes/utf-8) 229 | (, , ,bytes->string/utf-8) 230 | (, , ,string->path) 231 | (, , ,path->string) 232 | (, , ,bytes->path) 233 | (, , ,path->bytes) 234 | ;; Some weird combinations 235 | (, , ,string->number ,symbol->string) 236 | (, , ,string->symbol ,number->string) 237 | (, , ,vector->list ,struct->vector) 238 | (, , ,string->number ,bytes->string/utf-8) 239 | (, , ,string->bytes/utf-8 ,number->string) 240 | )) 241 | 242 | ;;; --------------------------------------------------------------------------- 243 | ;;; Recursive equality. 244 | 245 | ;;>> (equals? x y) 246 | ;;> A generic that compares `x' and `y'. It has an around method that 247 | ;;> will stop and return `#t' if the two arguments are `equal?'. It is 248 | ;;> intended for user-defined comparison between any instances. 249 | (defgeneric* equals? (x y)) 250 | 251 | (defaroundmethod (equals? [x ] [y ]) 252 | ;; check this first in all cases 253 | (or (equal? x y) (call-next-method))) 254 | 255 | (defmethod (equals? [x ] [y ]) 256 | ;; the default is false - the around method returns #t if they're equal? 257 | #f) 258 | 259 | ;;>> (add-equals?-method class pred?) 260 | ;;> Adds a method to `equals?' that will use the given `pred?' predicate 261 | ;;> to compare instances of `class'. 262 | (define* (add-equals?-method class pred?) 263 | (add-method equals? (method ([x class] [y class]) (pred? x y)))) 264 | 265 | ;;>> (class+slots-equals? x y) 266 | ;;> This is a predicate function (not a generic function) that will 267 | ;;> succeed if `x' and `y' are instances of the same class, and all of 268 | ;;> their corresponding slots are `equals?'. This is useful as a quick 269 | ;;> default for comparing simple classes (but be careful and avoid 270 | ;;> circularity problems). 271 | (define* (class+slots-equals? x y) 272 | (let ([xc (class-of x)] [yc (class-of y)]) 273 | (and (eq? xc yc) 274 | (every (lambda (s) 275 | (equals? (slot-ref x (car s)) (slot-ref y (car s)))) 276 | (class-slots xc))))) 277 | 278 | ;;>> (make-equals?-compare-class+slots class) 279 | ;;> Make `class' use `class+slots-equals?' for comparison with `equals?'. 280 | (define* (make-equals?-compare-class+slots class) 281 | (add-equals?-method class class+slots-equals?)) 282 | 283 | ;;; --------------------------------------------------------------------------- 284 | ;;; Generic addition for multiple types. 285 | 286 | ;;>> (add x ...) 287 | ;;> A generic addition operation, initialized for some Scheme types 288 | ;;> (numbers (+), lists (append), strings (string-append), symbols 289 | ;;> (symbol-append), procedures (compose), and vectors). It dispatches 290 | ;;> only on the first argument. 291 | (defgeneric* add (x . more)) 292 | 293 | ;;>> (add-add-method class op) 294 | ;;> Add a method to `add' that will use `op' to add objects of class 295 | ;;> `class'. 296 | (define* (add-add-method c op) 297 | ;; dispatch on first argument 298 | (add-method add (method ([x c] . more) (apply op x more)))) 299 | 300 | (add-add-method +) 301 | (add-add-method append) 302 | (add-add-method string-append) 303 | (add-add-method symbol-append) 304 | (add-add-method compose) 305 | 306 | (defmethod (add [v ] . more) 307 | ;; long but better than vectors->lists->append->vectors 308 | (let* ([len (apply + (map vector-length (cons v more)))] 309 | [vec (make-vector len)]) 310 | (let loop ([i 0] [v v] [vs more]) 311 | (dotimes [j (vector-length v)] 312 | (set! (vector-ref vec (+ i j)) (vector-ref v j))) 313 | (unless (null? vs) (loop (+ i (vector-length v)) (car vs) (cdr vs)))) 314 | vec)) 315 | 316 | ;;; --------------------------------------------------------------------------- 317 | ;;; Generic len for multiple types. 318 | 319 | ;;>> (len x) 320 | ;;> A generic length operation, initialized for some Scheme types (lists 321 | ;;> (length), strings (string-length), vectors (vector-length)). 322 | (defgeneric* len (x)) 323 | 324 | ;;>> (add-len-method class op) 325 | ;;> Add a method to `len' that will use `op' to measure objects length for 326 | ;;> instances of `class'. 327 | (define* (add-len-method c op) 328 | (add-method len (method ([x c]) (op x)))) 329 | 330 | (add-len-method length) 331 | (add-len-method string-length) 332 | (add-len-method vector-length) 333 | 334 | ;;; --------------------------------------------------------------------------- 335 | ;;; Generic ref for multiple types. 336 | 337 | ;;>> (ref x indexes...) 338 | ;;> A generic reference operation, initialized for some Scheme types and 339 | ;;> instances. Methods are predefined for lists, vectors, strings, 340 | ;;> objects, hash-tables, boxes, promises, parameters, and namespaces. 341 | (defgeneric* ref (x . indexes)) 342 | 343 | ;;>> (add-ref-method class op) 344 | ;;> Add a method to `ref' that will use `op' to reference objects of class 345 | ;;> `class'. 346 | (define* (add-ref-method c op) 347 | (add-method ref (method ([x c] . indexes) (op x . indexes)))) 348 | 349 | (add-ref-method list-ref) 350 | (add-ref-method vector-ref) 351 | (add-ref-method string-ref) 352 | (add-ref-method slot-ref) 353 | (add-ref-method hash-table-get) 354 | (add-ref-method unbox) 355 | (add-ref-method force) 356 | (defmethod (ref [p ] . _) (p)) 357 | (defmethod (ref [n ] . args) 358 | (parameterize ([current-namespace n]) 359 | (apply namespace-variable-value args))) 360 | 361 | ;;; --------------------------------------------------------------------------- 362 | ;;; Generic set-ref! for multiple types. 363 | 364 | ;;>> (put! x v indexes) 365 | ;;> A generic setter operation, initialized for some Scheme types and 366 | ;;> instances. The new value comes first so it is possible to add methods 367 | ;;> to specialize on it. Methods are predefined for lists, vectors, 368 | ;;> strings, objects, hash-tables, boxes, parameters, and namespaces. 369 | (defgeneric* put! (x v . indexes)) 370 | 371 | ;;>> (add-put!-method class op) 372 | ;;> Add a method to `put!' that will use `op' to change objects of class 373 | ;;> `class'. 374 | (define* (add-put!-method c op) 375 | (add-method put! (method ([x c] v . indexes) (op x v . indexes)))) 376 | 377 | ;;>> (set-ref! x indexes... v) 378 | ;;> This syntax will just translate to `(put! x v indexes...)'. It makes 379 | ;;> it possible to make `(set! (ref ...) ...)' work with `put!'. 380 | (defsyntax* (set-ref! stx) 381 | (syntax-case stx () 382 | [(_ x i ...) 383 | (let* ([ris (reverse (syntax->list #'(i ...)))] 384 | [idxs (reverse (cdr ris))] 385 | [val (car ris)]) 386 | (quasisyntax/loc stx 387 | (put! x #,val #,@(datum->syntax-object #'(i ...) idxs #'(i ...)))))])) 388 | 389 | (define (put!-arg typename args) 390 | (if (or (null? args) (pair? (cdr args))) 391 | (if (null? args) 392 | (error 'put! "got no index for a ~a argument" typename) 393 | (error 'put! "got more than one index for a ~a argument ~e" 394 | typename args)) 395 | (car args))) 396 | 397 | #| 398 | (defmethod (put! [l ] x . i_) 399 | (list-set! l (put!-arg ' i_) x)) 400 | |# 401 | (defmethod (put! [v ] x . i_) 402 | (vector-set! v (put!-arg ' i_) x)) 403 | (defmethod (put! [s ] [c ] . i_) 404 | (string-set! s (put!-arg ' i_) c)) 405 | (defmethod (put! [o ] x . s_) 406 | (slot-set! o (put!-arg ' s_) x)) 407 | (defmethod (put! [h ] x . k_) 408 | (if (null? k_) 409 | (error 'put! "got no index for a argument") 410 | (hash-table-put! h (car k_) x))) 411 | (add-put!-method set-unbox!) 412 | (defmethod (put! [p ] x . _) 413 | (if (null? _) 414 | (p x) 415 | (error 'put! "got extraneous indexes for a argument"))) 416 | (defmethod (put! [n ] x . v_) 417 | (if (null? v_) 418 | (error 'put! "got no index for a argument") 419 | (parameterize ([current-namespace n]) 420 | (apply namespace-set-variable-value! (car v_) x 421 | (if (null? (cdr v_)) '() (list (cadr v_))))))) 422 | 423 | ;;; --------------------------------------------------------------------------- 424 | ;;>>... Generic-based printing mechanism 425 | 426 | ;;>> *print-level* 427 | ;;>> *print-length* 428 | ;;> These parameters control how many levels deep a nested data object 429 | ;;> will print, and how many elements are printed at each level. `#f' 430 | ;;> means no limit. The effect is similar to the corresponding globals in 431 | ;;> Lisp. Only affects printing of container objects (like lists, vectors 432 | ;;> and structures). 433 | (define* *print-level* (make-parameter 6)) 434 | (define* *print-length* (make-parameter 20)) 435 | 436 | ;; grab the builtin write/display handlers 437 | (define-values (mz:write mz:display) 438 | (let ([p (open-output-bytes)]) 439 | (values (port-write-handler p) (port-display-handler p)))) 440 | 441 | ;;>> (print-object obj esc? port) 442 | ;;> Prints `obj' on `port' using the above parameters -- the effect of 443 | ;;> `esc?' being true is to use a `write'-like printout rather than a 444 | ;;> `display'-like printout when it is false. Primitive Scheme values are 445 | ;;> printed normally, Swindle objects are printed using the un-`read'-able 446 | ;;> "#<...>" sequence unless a method that handles them is defined. For 447 | ;;> this printout, objects with a `name' slot are printed using that name 448 | ;;> (and their class's name). 449 | ;;> 450 | ;;> Warning: this is the method used for user-interaction output, errors 451 | ;;> etc. Make sure you only define reliable methods for it. 452 | (defgeneric* print-object (object esc? port)) 453 | 454 | (defmethod (print-object o esc? port) 455 | (mz:display "#" port) 456 | (mz:display (class-name (class-of o)) port)) 457 | 458 | (defmethod (print-object [o ] esc? port) 459 | ((if esc? mz:write mz:display) o port)) 460 | 461 | (define printer:too-deep "#?#") 462 | (define printer:too-long "...") 463 | 464 | ;; use a single implementation for both pairs and mpairs, punctuation 465 | ;; shorthands for pairs only 466 | (defmethod (print-object [o ] esc? port) 467 | (let ([punct (and (pair? (cdr o)) (null? (cddr o)) 468 | (assq (car o) 469 | '([quote "'"] [quasiquote "`"] [unquote ","] 470 | [unquote-splicing ",@"] 471 | [syntax "#'"] [quasisyntax "#`"] [unsyntax "#,"] 472 | [unsyntax-splicing "#,@"])))]) 473 | (if punct 474 | (begin (mz:display (cadr punct) port) (print-object (cadr o) esc? port)) 475 | (print-pair o esc? port "(" ")" pair? car cdr)))) 476 | (defmethod (print-object [o ] esc? port) 477 | (print-pair o esc? port "{" "}" mpair? mcar mcdr)) 478 | (define (print-pair p esc? port open close pair? car cdr) 479 | (define level (*print-level*)) 480 | (if (eq? level 0) 481 | (mz:display printer:too-deep port) 482 | (begin 483 | (mz:display open port) 484 | (if (eq? (*print-length*) 0) 485 | (mz:display printer:too-long port) 486 | (parameterize ([*print-level* (and level (sub1 level))]) 487 | (print-object (car p) esc? port) 488 | (do ([p (cdr p) (if (pair? p) (cdr p) '())] 489 | [n (sub1 (or (*print-length*) 0)) (sub1 n)]) 490 | [(or (null? p) 491 | (and (zero? n) 492 | (begin (mz:display " " port) 493 | (mz:display printer:too-long port) 494 | #t)))] 495 | (if (pair? p) 496 | (begin (mz:display " " port) (print-object (car p) esc? port)) 497 | (begin (mz:display " . " port) (print-object p esc? port)))))) 498 | (mz:display close port)))) 499 | 500 | (defmethod (print-object [o ] esc? port) 501 | (define level (*print-level*)) 502 | (cond [(eq? level 0) (mz:display printer:too-deep port)] 503 | [(zero? (vector-length o)) (mz:display "#()" port)] 504 | [else (mz:display "#(" port) 505 | (if (eq? (*print-length*) 0) 506 | (mz:display printer:too-long port) 507 | (parameterize ([*print-level* (and level (sub1 level))]) 508 | (print-object (vector-ref o 0) esc? port) 509 | (let ([len (if (*print-length*) 510 | (min (vector-length o) (*print-length*)) 511 | (vector-length o))]) 512 | (do ([i 1 (add1 i)]) [(>= i len)] 513 | (mz:display " " port) 514 | (print-object (vector-ref o i) esc? port)) 515 | (when (< len (vector-length o)) 516 | (mz:display " " port) 517 | (mz:display printer:too-long port))))) 518 | (mz:display ")" port)])) 519 | 520 | ;;>> (name-sans-<> name) 521 | ;;> Given a string or symbol for name, return a string where the outermost 522 | ;;> set of angle brackets have been stripped if they are present. This is 523 | ;;> handy if you are writing your own print-object methods. 524 | (define <>-re #rx"^<(.*)>$") 525 | (define* (name-sans-<> name) 526 | (cond [(string? name) (regexp-replace <>-re name "\\1")] 527 | [(symbol? name) (regexp-replace <>-re (symbol->string name) "\\1")] 528 | [(eq? ??? name) "???"] 529 | [else name])) 530 | 531 | ;; Take care of all s with a `name' slot 532 | (defmethod (print-object (o ) esc? port) 533 | (let* ([c (class-of o)] 534 | [cc (class-of c)] 535 | [(name x) (name-sans-<> (slot-ref x 'name))]) 536 | (if (and (assq 'name (class-slots c)) (assq 'name (class-slots cc))) 537 | (begin (mz:display "#<" port) 538 | (mz:display (name c) port) 539 | (mz:display ":" port) 540 | (mz:display (name o) port) 541 | (mz:display ">" port)) 542 | (call-next-method)))) 543 | 544 | ;;>> (print-object-with-slots obj esc? port) 545 | ;;> This is a printer function that can be used for classes where the 546 | ;;> desired output shows slot values. Note that it is a simple function, 547 | ;;> which should be embedded in a method that is to be added to 548 | ;;> `print-object'. 549 | (define* (print-object-with-slots o esc? port) 550 | (define level (*print-level*)) 551 | (if (eq? level 0) 552 | (mz:display printer:too-deep port) 553 | (let ([class (class-of o)]) 554 | (mz:display "#<" port) 555 | (mz:display (name-sans-<> (class-name class)) port) 556 | (mz:display ":" port) 557 | (parameterize ([*print-level* (and level (sub1 level))]) 558 | (do ([s (class-slots class) (cdr s)] 559 | [n (or (*print-length*) -1) (sub1 n)]) 560 | [(or (null? s) 561 | (and (zero? n) 562 | (begin (mz:display " " port) 563 | (mz:display printer:too-long port))))] 564 | (let ([val (slot-ref o (caar s))]) 565 | (if (eq? ??? val) 566 | (set! n (add1 n)) 567 | (begin (mz:display " " port) 568 | (mz:display (caar s) port) 569 | (mz:display "=" port) 570 | (print-object val esc? port)))))) 571 | (mz:display ">" port)))) 572 | 573 | ;; Add a hook to make so it will initialize a printer if given 574 | (defmethod :after (initialize [c ] initargs) 575 | (let ([printer (or (getarg initargs :printer) 576 | (and (getarg initargs :auto) #t))]) 577 | (when printer 578 | (when (eq? #t printer) (set! printer print-object-with-slots)) 579 | (add-method print-object 580 | (method ([x c] esc? port) (printer x esc? port)))))) 581 | 582 | ;;>> (display-object obj [port]) 583 | ;;>> (write-object obj [port]) 584 | ;;> Used to display and write an object using `print-object'. Used as the 585 | ;;> corresponding output handler functions. 586 | (define* (display-object obj &optional [port (current-output-port)]) 587 | (print-object obj #f port)) 588 | (define* (write-object obj &optional [port (current-output-port)]) 589 | (print-object obj #t port)) 590 | ;;>> (object->string obj [esc? = #t]) 591 | ;;> Convert the given `obj' to a string using its printed form. 592 | (define* (object->string obj &optional [esc? #t]) 593 | (with-output-to-string 594 | (thunk (print-object obj esc? (current-output-port))))) 595 | 596 | ;; Hack these to echo 597 | (*echo-display-handler* display-object) 598 | (*echo-write-handler* write-object) 599 | 600 | ;;>> (install-swindle-printer) 601 | ;;> In Racket, output is configurable on a per-port basis. Use this 602 | ;;> function to install Swindle's `display-object' and `write-object' on 603 | ;;> the current output and error ports whenever they are changed 604 | ;;> (`swindle' does that on startup). This makes it possible to see 605 | ;;> Swindle values in errors, when using `printf' etc. 606 | (define* (install-swindle-printer) 607 | (global-port-print-handler write-object) 608 | (port-display-handler (current-output-port) display-object) 609 | (port-display-handler (current-error-port) display-object) 610 | (port-write-handler (current-output-port) write-object) 611 | (port-write-handler (current-error-port) write-object)) 612 | 613 | ;;; --------------------------------------------------------------------------- 614 | ;;>>... Simple matching 615 | 616 | ;;>> match-failure 617 | ;;> The result for a matcher function application that failed. You can 618 | ;;> return this value from a matcher function in a so the next 619 | ;;> matching one will get invoked. 620 | (define* match-failure "failure") 621 | 622 | ;;>> (matching? matcher value) 623 | ;;> The `matcher' argument is a value of any type, which is matched 624 | ;;> against the given `value'. For most values matching means being equal 625 | ;;> (using `equals?') to, but there are some exceptions: class objects 626 | ;;> are tested with `instance-of?', functions are used as predicates, 627 | ;;> literals are used with equals?, pairs are compared recursively and 628 | ;;> regexps are used with regexp-match. 629 | (define* (matching? matcher value) 630 | (cond [(class? matcher) (instance-of? value matcher)] 631 | [(function? matcher) (matcher value)] 632 | [(pair? matcher) (and (pair? value) 633 | (matching? (car matcher) (car value)) 634 | (matching? (cdr matcher) (cdr value)))] 635 | ;; handle regexps - the code below relies on returning this result 636 | [(regexp? matcher) (and (string? value) 637 | (regexp-match matcher value))] 638 | [else (equals? matcher value)])) 639 | 640 | ;;>> (let/match pattern value body ...) 641 | ;;> Match the `value' against the given `pattern', and evaluate the body 642 | ;;> on a success. It is an error for the match to fail. Variables that 643 | ;;> get bound in the matching process can be used in the body. 644 | ;;> 645 | ;;> The pattern specification has a complex syntax as follows: 646 | ;;> - simple values (not symbols) are compared with `matching?' above; 647 | ;;> - :x keywords are also used as literal values; 648 | ;;> - * is a wildcard that always succeeds; 649 | ;;> - ??? matches the `???' value; 650 | ;;> - (lambda ...) use the resulting closure value (for predicates); 651 | ;;> - (quote ...) use the contents as a simple value; 652 | ;;> - (quasiquote ...) same; 653 | ;;> - (V := P) assign the variable V to the value matched by P; 654 | ;;> - V for a variable name V that was not part of the 655 | ;;> pattern so far, this matches anything and binds V 656 | ;;> to the value -- the same as (V := *); 657 | ;;> - (! E) evaluate E, use the result as a literal value; 658 | ;;> - (!! E) evaluate E, continue matching only if it is true; 659 | ;;> - (V when E) same as (and V (!! E)); 660 | ;;> - (and P ...) combine the matchers with and, can bind any 661 | ;;> variables in all parts; 662 | ;;> - (or P ...) combine the matchers with or, bound variables are 663 | ;;> only from the successful form; 664 | ;;> - (if A B C) same as (or (and A B) C); 665 | ;;> - (F => P) continue matching P with (F x) (where is x is the 666 | ;;> current matched object); 667 | ;;> - (V :: P ...) same as (and (! V) P...), useful for class forms 668 | ;;> like ( :: (foo => f) ...); 669 | ;;> - (make ...) if the value is an instance of , then 670 | ;;> continue by the `...' part which is a list of 671 | ;;> slot names and patterns -- a slot name is either 672 | ;;> :foo or 'foo, and the pattern will be matched 673 | ;;> against the contents of that slot in the original 674 | ;;> instance; 675 | ;;> - ??? matches the unspecified value (`???' in tiny-clos) 676 | ;;> - (regexp R) convert R to a regexp and use that to match 677 | ;;> strings; 678 | ;;> - (regexp R P ...) like the above, but continue matching the result 679 | ;;> with `(P ...)' so it can bind variables to the 680 | ;;> result (something like `(regexp "a(x?)b" x y)' 681 | ;;> will bind `x' to the `regexp-match' result, and 682 | ;;> `y' to a match of the sub-regexp part); 683 | ;;> - (...) other lists - match the elements of a list 684 | ;;> recursively (can use a dot suffix for a "rest" 685 | ;;> arguments). 686 | ;;> 687 | ;;> Note that variable names match anything and bind the name to the result, 688 | ;;> except when the name was already seen -- where the previously bound 689 | ;;> value is used, allowing patterns where some parts should match the same 690 | ;;> value. (A name was `seen' if it was previously used in the pattern 691 | ;;> except on different branches of an `or' pattern.) 692 | (defsyntax (make-matcher-form stx) 693 | (define (re r) 694 | ;; Note: this inserts the _literal_ regexp in the code if it is a string. 695 | (cond [(regexp? (syntax-e r)) r] 696 | [(string? (syntax-e r)) (regexp (syntax-e r))] 697 | [else #`(regexp #,r)])) 698 | (define (loop x pattern vs body) 699 | ;; body always a delayed function that expects bindings 700 | (syntax-case pattern (* ??? := ! !! when and or if => :: 701 | make regexp quote quasiquote lambda) 702 | [* ; wildcard 703 | (body vs)] 704 | [??? ; matches ??? 705 | #`(if (matching? ??? #,x) #,(body vs) match-failure)] 706 | [(v := p) ; assign the variable V to the value matched by P 707 | #`(let ([v #,x]) #,(loop #'v #'p (cons #'v vs) body))] 708 | [v ; (V := *) if V is a symbol that was not already used 709 | (and (identifier? #'v) (not (syntax-keyword? #'v)) 710 | (not (ormap (lambda (u) (bound-identifier=? #'v u)) vs))) 711 | (loop x #'(v := *) vs body)] 712 | [(! e) ; evaluate E and use it as a simple value 713 | #`(if (matching? e x) #,(body vs) match-failure)] 714 | [(!! e) ; evaluate E and succeed only if it is true 715 | #`(if e #,(body vs) match-failure)] 716 | [(p when e) ; => (and P (!! E)) 717 | #`(_ x (and p (!! e)) #,(body vs))] 718 | ;; and/or 719 | [(and) (body vs)] 720 | [(or) #'match-failure] 721 | [(and p) (loop x #'p vs body)] 722 | [(or p) (loop x #'p vs body)] 723 | [(and p1 p2 ...) (loop x #'p1 vs 724 | (lambda (vs) (loop x #'(and p2 ...) vs body)))] 725 | [(or p1 p2 ...) #`(let ([tmp #,(loop x #'p1 vs body)]) 726 | (if (eq? tmp match-failure) 727 | #,(loop x #'(or p2 ...) vs body) 728 | tmp))] 729 | [(if a b c) ; => (or (and A B) C) 730 | (loop x #'(or (and a b) c) vs body)] 731 | [(f => p) ; continue matching P with (F x) 732 | #`(let ([v (f #,x)]) #,(loop #'v #'p vs body))] 733 | [(v :: . p) ; => (and (! V) P ...), eg ( :: (foo => f) ...) 734 | (loop x #'(and (! v) . p) vs body)] 735 | [(make class initarg+vals ...) 736 | ;; (make :slotname p ...) - match on slots of the given class 737 | #`(let ([obj #,x]) 738 | (if (instance-of? obj class) 739 | #,(let loop1 ([av #'(initarg+vals ...)] [vs vs]) 740 | (syntax-case av (quote) 741 | [(key p more ...) (syntax-keyword? #'key) 742 | (let* ([s (symbol->string (syntax-e #'key))] 743 | [s (datum->syntax-object 744 | #'key 745 | (string->symbol 746 | (substring s 1 (string-length s))) 747 | #'key)]) 748 | (loop #`(slot-ref obj '#,s) #'p vs 749 | (lambda (vs) (loop1 #'(more ...) vs))))] 750 | [('key p more ...) 751 | (loop #'(slot-ref obj 'key) #'p vs 752 | (lambda (vs) (loop1 #'(more ...) vs)))] 753 | [() (body vs)])) 754 | match-failure))] 755 | [(regexp r) ; use R as a regexp (matching? handles it) 756 | #`(if (matching? #,(re #'r) #,x) #,(body vs) match-failure)] 757 | [(regexp r . p) ; => like the above, but match P... on result 758 | #`(let ([m (matching? #,(re #'r) #,x)]) 759 | (if m #,(loop #'m #'p vs body) match-failure))] 760 | ;; literal lists 761 | ['v #`(if (matching? 'v #,x) #,(body vs) match-failure)] 762 | [`v #`(if (matching? `v #,x) #,(body vs) match-failure)] 763 | [(lambda as b ...) 764 | #`(if (matching? (lambda as b ...) #,x) #,(body vs) match-failure)] 765 | [(a . b) ; simple lists 766 | #`(if (pair? #,x) 767 | (let ([hd (car #,x)] [tl (cdr #,x)]) 768 | #,(loop #'hd #'a vs (lambda (vs) (loop #'tl #'b vs body)))) 769 | match-failure)] 770 | ;; other literals (null, keywords, non-symbols) 771 | [() #`(if (null? #,x) #,(body vs) match-failure)] 772 | [v #`(if (matching? v #,x) #,(body vs) match-failure)])) 773 | (syntax-case stx () 774 | [(_ x pattern body) (loop #'x #'pattern '() (lambda (vs) #'body))])) 775 | (defsubst* (let/match pattern value body ...) 776 | (let* ([v value] [r (make-matcher-form v pattern (begin body ...))]) 777 | (if (eq? r match-failure) 778 | (error 'let/match "value did not match pattern: ~e" v) 779 | r))) 780 | 781 | ;;>> (matcher pattern body ...) 782 | ;;> This creates a matcher function, using the given `pattern' which will 783 | ;;> be matched with the list of given arguments on usage. If the given 784 | ;;> arguments fail to match on an application, an error will be raised. 785 | (defsubst* (matcher pattern body ...) 786 | (lambda args 787 | (let ([r (make-matcher-form args pattern (begin body ...))]) 788 | (if (eq? r match-failure) 789 | (error 'matcher "application values did not match pattern: ~e" v) 790 | r)))) 791 | 792 | ;; Matching similar to `cond' 793 | ;;>> (match x (pattern expr ...) ...) 794 | ;;> This is similar to a `cond' statement but each clause starts with a 795 | ;;> pattern, possibly binding variables for its body. It also handles 796 | ;;> `else' as a last clause. 797 | (defsyntax match-internal 798 | (syntax-rules (else) 799 | [(_ x) (void)] 800 | [(_ x (else body0 body ...)) (begin body0 body ...)] 801 | [(_ x (pattern body0 body ...) clause ...) 802 | (let ([m (make-matcher-form x pattern (begin body0 body ...))]) 803 | (if (eq? m match-failure) (match x clause ...) m))])) 804 | (defsubst* (match x clause ...) 805 | (let ([v x]) (match-internal v clause ...))) 806 | 807 | ;;>> 808 | ;;> A class similar to a generic function, that holds matcher functions 809 | ;;> such as the ones created by the `matcher' macro. It has three slots: 810 | ;;> `name', `default' (either a default value or a function that is 811 | ;;> applied to the arguments to produce the default value), and `matchers' 812 | ;;> (a list of matcher functions). 813 | (defentityclass* () 814 | (name :initarg :name :initvalue '-anonymous-) 815 | (default :initarg :default :initvalue #f) 816 | (matchers :initarg :matchers :initvalue '())) 817 | 818 | ;; Set the entity's proc 819 | (defmethod (initialize [matcher ] initargs) 820 | (call-next-method) 821 | (set-instance-proc! 822 | matcher 823 | (lambda args 824 | (let loop ([matchers (slot-ref matcher 'matchers)]) 825 | (if (null? matchers) 826 | (let ([default (slot-ref matcher 'default)]) 827 | (if (procedure? default) 828 | (default . args) 829 | (or default 830 | (error (slot-ref matcher 'name) "no match found.")))) 831 | (let ([r (apply (car matchers) args)]) 832 | (if (eq? r match-failure) 833 | (loop (cdr matchers)) 834 | r))))))) 835 | 836 | ;;; Add a matcher - normally at the end, with add-matcher0 at the beginning 837 | (define (add-matcher matcher m) 838 | (slot-set! matcher 'matchers 839 | (append (slot-ref matcher 'matchers) (list m)))) 840 | (define (add-matcher0 matcher m) 841 | (slot-set! matcher 'matchers 842 | (cons m (slot-ref matcher 'matchers)))) 843 | 844 | (defsyntax (defmatcher-internal stx) 845 | (syntax-case stx () 846 | [(_ adder name args body ...) 847 | (with-syntax ([matcher-make (syntax/loc stx (matcher args body ...))]) 848 | (if (or 849 | ;; not enabled 850 | (not (syntax-e 851 | ((syntax-local-value #'-defmethod-create-generics-)))) 852 | ;; defined symbol or second module binding 853 | (identifier-binding #'name) 854 | ;; local definition -- don't know which is first => no define 855 | (eq? 'lexical (syntax-local-context))) 856 | (syntax/loc stx (adder name matcher-make)) 857 | ;; top-level or first module binding 858 | (syntax/loc stx 859 | (define name ; trick: try using exising generic 860 | (let ([m (or (no-errors name) (make :name 'name))]) 861 | (adder m matcher-make) 862 | m)))))])) 863 | 864 | ;;>> (defmatcher (name pattern) body ...) 865 | ;;>> (defmatcher0 (name pattern) body ...) 866 | ;;> These macros define a matcher (if not defined yet), create a matcher 867 | ;;> function and add it to the matcher (either at the end (defmatcher) or 868 | ;;> at the beginning (defmatcher0)). 869 | (defsyntax* (defmatcher stx) 870 | (syntax-case stx () 871 | [(_ (name . args) body0 body ...) (identifier? #'name) 872 | #'(defmatcher-internal add-matcher name args body0 body ...)] 873 | [(_ name args body0 body ...) (identifier? #'name) 874 | #'(defmatcher-internal add-matcher name args body0 body ...)])) 875 | (defsyntax* (defmatcher0 stx) 876 | (syntax-case stx () 877 | [(_ (name . args) body0 body ...) (identifier? #'name) 878 | #'(defmatcher-internal add-matcher0 name args body0 body ...)] 879 | [(_ name args body0 body ...) (identifier? #'name) 880 | #'(defmatcher-internal add-matcher0 name args body0 body ...)])) 881 | 882 | ;;; --------------------------------------------------------------------------- 883 | ;;>>... An amb macro 884 | ;;> This is added just because it is too much fun to miss. To learn about 885 | ;;> `amb', look for it in the Help Desk, in the "Teach Yourself Scheme in 886 | ;;> Fixnum Days" on-line manual. 887 | 888 | (define amb-fail (make-parameter #f)) 889 | (define (initialize-amb-fail) 890 | (amb-fail (thunk (error 'amb "tree exhausted")))) 891 | (initialize-amb-fail) 892 | 893 | ;;>> (amb expr ...) 894 | ;;> Execute forms in a nondeterministic way: each form is tried in 895 | ;;> sequence, and if one fails then evaluation continues with the next. 896 | ;;> `(amb)' fails immediately. 897 | (defsubst* (amb expr ...) 898 | (let ([prev-amb-fail (amb-fail)]) 899 | (let/ec sk 900 | (let/cc fk 901 | (amb-fail (thunk (amb-fail prev-amb-fail) (fk 'fail))) 902 | (sk expr)) ... 903 | (prev-amb-fail)))) 904 | 905 | ;;>> (amb-assert cond) 906 | ;;> Asserts that `cond' is true, fails otherwise. 907 | (define* (amb-assert bool) (unless bool ((amb-fail)))) 908 | 909 | ;;>> (amb-collect expr) 910 | ;;> Evaluate expr, using amb-fail repeatedly until all options are 911 | ;;> exhausted and returns the list of all results. 912 | (defsubst* (amb-collect e) 913 | (let ([prev-amb-fail (amb-fail)] 914 | [results '()]) 915 | (when (let/cc k 916 | (amb-fail (thunk (k #f))) 917 | (let ([v e]) (push! v results) (k #t))) 918 | ((amb-fail))) 919 | (amb-fail prev-amb-fail) 920 | (reverse results))) 921 | 922 | ;;; --------------------------------------------------------------------------- 923 | ;;>>... Very basic UI - works also in console mode 924 | ;;> The following defines some hacked UI functions that works using GRacket 925 | ;;> GUI if it is available, or the standard error and input ports otherwise. 926 | ;;> The check is done by looking for a GUI global binding. 927 | 928 | ;;>> *dialog-title* 929 | ;;> This parameter defines the title used for the hacked UI interface. 930 | (define* *dialog-title* (make-parameter "Swindle Message")) 931 | 932 | ;;>> (message fmt-string arg ...) 933 | ;;> Like `printf' with a prefix title, or using a message dialog box. 934 | (define* (message str . args) 935 | (let ([msg (format str . args)]) 936 | (if (namespace-defined? 'message-box) 937 | ((namespace-variable-value 'message-box) (*dialog-title*) msg) 938 | (echo :>e :s- "<<<" (*dialog-title*) ": " msg ">>>"))) 939 | (void)) 940 | 941 | (define (first-non-ws-char str idx) 942 | (and (< idx (string-length str)) 943 | (let ([c (string-ref str idx)]) 944 | (if (memq c '(#\space #\tab #\newline)) 945 | (first-non-ws-char str (add1 idx)) 946 | c)))) 947 | 948 | (define (ui-question str args prompt positive-result msg-style 949 | positive-char negative-char) 950 | (let ([msg (apply format str args)]) 951 | (if (namespace-defined? 'message-box) 952 | (eq? ((namespace-variable-value 'message-box) 953 | (*dialog-title*) msg #f msg-style) 954 | positive-result) 955 | (begin (echo :>e :n- :s- (*dialog-title*) ">>> " msg " " prompt " ") 956 | (let loop () 957 | (let ([inp (first-non-ws-char (read-line) 0)]) 958 | (cond [(char-ci=? inp positive-char) #t] 959 | [(char-ci=? inp negative-char) #f] 960 | [else (loop)]))))))) 961 | 962 | ;;>> (ok/cancel? fmt-string arg ...) 963 | ;;>> (yes/no? fmt-string arg ...) 964 | ;;> These functions are similar to `message', but they are used to ask an 965 | ;;> "ok/cancel" or a "yes/no" question. They return a boolean. 966 | (define* (ok/cancel? str . args) 967 | (ui-question str args "Ok/Cancel" 'ok '(ok-cancel) #\o #\c)) 968 | (define* (yes/no? str . args) 969 | (ui-question str args "Yes/No" 'yes '(yes-no) #\y #\n)) 970 | --------------------------------------------------------------------------------