733 lines
36 KiB
Racket
733 lines
36 KiB
Racket
;;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)
|
|
|
|
;;> This module contains only syntax definitions, which makes Swindle closer
|
|
;;> to CLOS -- making the object system much more convenient to use.
|
|
|
|
#lang s-exp swindle/turbo
|
|
|
|
(require swindle/tiny-clos)
|
|
(provide (all-from swindle/tiny-clos))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; General helpers
|
|
|
|
(defsyntax (args-arity stx)
|
|
(syntax-case stx ()
|
|
[(_ args)
|
|
(let loop ([args #'args] [n 0])
|
|
(syntax-case args ()
|
|
[(a . more)
|
|
(or (not (identifier? #'a))
|
|
;; stop at &-keyword
|
|
(let ([sym (syntax-e #'a)])
|
|
(or (eq? sym '||)
|
|
(not (eq? #\& (string-ref (symbol->string sym) 0))))))
|
|
(loop #'more (add1 n))]
|
|
[() (datum->syntax-object stx n stx)]
|
|
[_ (quasisyntax/loc stx (make-arity-at-least #,n))]))]))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Generic macros
|
|
|
|
;;>>... Generic macros
|
|
|
|
;;>> (generic)
|
|
;;> | (generic name initargs ...)
|
|
;;> | (generic name (arg ...) initargs ...)
|
|
;;> Create a generic function object (an instance of the
|
|
;;> `*default-generic-class*' parameter). The first form uses the default
|
|
;;> name given by the syntactical context, the second one gets an explicit
|
|
;;> name and the third also gets a list of arguments which is used to
|
|
;;> count the required number of arguments. If there is no argument list
|
|
;;> to count, the first method that gets added will set this number. The
|
|
;;> two last forms allow initargs to be passed to the <generic> instance
|
|
;;> creation, for example, to specify a `:combination' argument. (The
|
|
;;> first form does not allow keywords, since a keyword would be taken as
|
|
;;> the name.)
|
|
(defsyntax* (generic stx)
|
|
(syntax-case stx ()
|
|
[(_)
|
|
#`(make (*default-generic-class*) :name '#,(syntax-local-name))]
|
|
[(_ name) (identifier? #'name)
|
|
#'(make (*default-generic-class*) :name 'name)]
|
|
[(_ name initarg initargs ...)
|
|
(and (identifier? #'name) (syntax-keyword? #'initarg))
|
|
#'(make (*default-generic-class*) initarg initargs ... :name 'name)]
|
|
[(_ name args) (identifier? #'name)
|
|
#`(make (*default-generic-class*)
|
|
:name 'name :arity (args-arity args))]
|
|
[(_ name args initarg initargs ...)
|
|
(and (identifier? #'name) (syntax-keyword? #'initarg))
|
|
#`(make (*default-generic-class*)
|
|
initarg initargs ... :name 'name :arity (args-arity args))]))
|
|
|
|
;;>> (defgeneric name (arg ...) initargs ...)
|
|
;;> | (defgeneric (name arg ...) initargs ...)
|
|
;;> | (defgeneric name initargs ...)
|
|
;;> This form defines a generic function using the `generic' syntax given
|
|
;;> above. The last form doesn't specify a number of arguments. Some
|
|
;;> extra `initargs' can be specified too but they are needed mainly for a
|
|
;;> `:combination' argument.
|
|
(defsyntax* (defgeneric stx)
|
|
(let* ([ctx (syntax-local-context)]
|
|
[ctx (cond [(pair? ctx) (car ctx)]
|
|
[(eq? ctx 'top-level) ctx]
|
|
[else #f])]
|
|
[mark (lambda (name)
|
|
((syntax-local-value #'generic-contexts-defined?) name ctx))])
|
|
(syntax-case stx ()
|
|
[(_ name args initargs ...) (identifier? #'name)
|
|
(begin (mark #'name) #'(define name (generic name args initargs ...)))]
|
|
[(_ (name . args) initargs ...) (identifier? #'name)
|
|
(begin (mark #'name) #'(define name (generic name args initargs ...)))]
|
|
[(_ name initargs ...) (identifier? #'name)
|
|
(begin (mark #'name) #'(define name (generic name initargs ...)))])))
|
|
|
|
;; returns #t if an identifier id in context ctx is already defined as a genric
|
|
;; (used by defmethod to detect when it should expand to an add-method)
|
|
(define-syntax generic-contexts-defined?
|
|
(let ([table (make-hash-table 'weak)])
|
|
(lambda (id ctx)
|
|
;; ctx is either the first element of (syntax-local-context) or
|
|
;; 'top-level. Note that top-level identifiers in different modules
|
|
;; should not be `module-identifier=?' (eg, `eval' takes care of this).
|
|
(let ([cs (hash-table-get table ctx (lambda () '()))])
|
|
(or (ormap (lambda (c) (module-identifier=? id c)) cs) ; defined
|
|
(begin (hash-table-put! table ctx (cons id cs)) ; undefined
|
|
#f))))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Method macros
|
|
|
|
;;>>... Method macros
|
|
|
|
;;>> (call-next-method [args ...]) [*local*]
|
|
;;>> (next-method?) [*local*]
|
|
;;> These are bindings which are available only in method bodies.
|
|
;;> `call-next-method' will invoke the next method in a generic invocation
|
|
;;> sequence if any. If arguments are given to `call-next-method', it
|
|
;;> will change the arguments for the next method -- but this is done when
|
|
;;> the methods are already filtered and sorted, so the new arguments
|
|
;;> should always be consistent with the old types. If there are no
|
|
;;> methods left, or when calling a method directly, or when a before or
|
|
;;> after method is used, the `no-next-method' generic will be used --
|
|
;;> normally resulting in an error. `next-method?' returns `#t' if there
|
|
;;> is another method ready to be called.
|
|
|
|
(defsyntax (make-method-specs/initargs stx)
|
|
(syntax-case stx ()
|
|
[(_ name args0 body . more)
|
|
(let loop ([args #'args0] [specializers '()] [arguments '()])
|
|
(syntax-case args (=)
|
|
[([arg = val] . rest)
|
|
(loop #'rest
|
|
(cons #'(singleton val) specializers) (cons #'arg arguments))]
|
|
[([arg type] . rest)
|
|
(loop #'rest (cons #'type specializers) (cons #'arg arguments))]
|
|
[([arg] . rest)
|
|
(loop #'rest (cons #'<top> specializers) (cons #'arg arguments))]
|
|
[(arg . rest)
|
|
(and (identifier? #'arg)
|
|
;; stop at &-keyword
|
|
(let ([sym (syntax-e #'arg)])
|
|
(or (eq? sym '||)
|
|
(not (eq? #\& (string-ref (symbol->string sym) 0))))))
|
|
(loop #'rest (cons #'<top> specializers) (cons #'arg arguments))]
|
|
[_ ; both null and rest argument
|
|
(let* ([specializers (reverse specializers)]
|
|
[arguments (reverse arguments)]
|
|
[name-e (syntax-e #'name)]
|
|
[cnm (datum->syntax-object
|
|
#'args0 'call-next-method #'args0)])
|
|
(unless (null? (syntax-e args))
|
|
(set! arguments
|
|
(if (null? arguments) args (append arguments args))))
|
|
(let ([makeit
|
|
(quasisyntax/loc stx
|
|
(make (*default-method-class*)
|
|
:specializers (list #,@specializers)
|
|
:name '#,(if name-e #'name (syntax-local-name))
|
|
:procedure
|
|
(lambda (#,cnm . #,arguments)
|
|
;; See "Trick" in tiny-clos.rkt
|
|
;; -- use a syntax to not do this unless needed
|
|
(letsyntax
|
|
([#,(datum->syntax-object
|
|
#'args0 'next-method? #'args0)
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(__) #'(not (eq? '*no-next-method*
|
|
(object-name #,cnm)))]
|
|
[(__ . xs)
|
|
#'((named-lambda next-method? () 1)
|
|
. xs)]
|
|
[__
|
|
#'(named-lambda next-method? ()
|
|
(not
|
|
(eq? '*no-next-method*
|
|
(object-name #,cnm))))]))])
|
|
. body))
|
|
. more))])
|
|
(if name-e
|
|
(quasisyntax/loc stx (letrec ([name #,makeit]) name))
|
|
makeit)))]))]))
|
|
|
|
;;>> (method (arg ...) body ...)
|
|
;;>> (named-method name (arg ...) body ...)
|
|
;;>> (qualified-method qualifier (arg ...) body ...)
|
|
;;> These forms are all similar variants to create a method object (and
|
|
;;> instance of the `*default-method-class*' parameter). A method looks
|
|
;;> very similar to a lambda expression, except that the an argument can
|
|
;;> be a of the form `[arg spec]' where `spec' is a specializer -- either
|
|
;;> a class or a singleton specifier (the square brackets are equivalent
|
|
;;> to round parens, just make the code more readable). Also, an argument
|
|
;;> can have the form of `[arg = val]' which is shorthand for specifying
|
|
;;> `[arg (singleton val)]'. In case of a simple argument, <top> is
|
|
;;> always used as a specializer, but this processing stops as soon as a
|
|
;;> &-keyword is encountered. The `named-method' form is used to provide
|
|
;;> an explicit name (which can be used to call itself recursively) , and
|
|
;;> `qualified-method' is used to provide an explicit qualifier (which
|
|
;;> should be one of the standard qualifiers (:primary, :around, :before,
|
|
;;> or :after) when using the standard <method> and <generic> classes).
|
|
;;>
|
|
;;> The resulting method can be added to a generic and these specializers
|
|
;;> will be used when filtering applicable methods, or it can be used by
|
|
;;> itself and the specializers will be used to check the arguments. This
|
|
;;> makes it easy to use `method' instead of `lambda' to get some type
|
|
;;> information, but note that the result is going to run slower since the
|
|
;;> type check only takes time but cannot be used by Racket to optimize
|
|
;;> the code.
|
|
;;>
|
|
;;> Note that the specializer argument are evaluated normally, which means
|
|
;;> that anything can be used, even something like:
|
|
;;> (let ([x (list <string> <integer>)])
|
|
;;> (method ([x (2nd x)] [y = (+ 2 3)]) (+ x y)))
|
|
(defsubst* (method args body0 body ...)
|
|
(make-method-specs/initargs #f args (body0 body ...)))
|
|
(defsubst* (named-method name args body0 body ...)
|
|
(make-method-specs/initargs name args (body0 body ...)))
|
|
(defsubst* (qualified-method qualifier args body0 body ...)
|
|
(make-method-specs/initargs #f args (body0 body ...) :qualifier qualifier))
|
|
|
|
;;>> (-defmethod-create-generics- [#t/#f])
|
|
;;> This is a syntax parameter (see above) holding a boolean. When this
|
|
;;> is set to `#t' (the default), then the `defmethod' form below will try
|
|
;;> to detect when the first definition happens and automatic add a
|
|
;;> `defgeneric' form to define the object as a generic. A safer but less
|
|
;;> convenient approach would be to set this to `#f' and always do an
|
|
;;> explicit `defgeneric'.
|
|
(define-syntax-parameter* -defmethod-create-generics- #t)
|
|
|
|
(defsyntax (method-def-adder stx)
|
|
(syntax-case stx ()
|
|
[(_ qualifier name args body ...) (identifier? #'name)
|
|
;; always make it with no name so add-method will add it
|
|
(with-syntax ([method-make (syntax/loc stx
|
|
(qualified-method qualifier args body ...))])
|
|
(let ([ctx (syntax-local-context)])
|
|
(cond
|
|
[(or ; if:
|
|
;; not enabled
|
|
(not (syntax-e ((syntax-local-value
|
|
#'-defmethod-create-generics-))))
|
|
;; expression position -- same as using add-method
|
|
(eq? 'expression ctx)
|
|
;; defined symbol or second module binding
|
|
(identifier-binding #'name)
|
|
;; already defined in this local context or top-level
|
|
(let ([ctx (cond [(pair? ctx) (car ctx)]
|
|
[(eq? ctx 'top-level) ctx]
|
|
[else #f])])
|
|
(and ctx ((syntax-local-value #'generic-contexts-defined?)
|
|
#'name ctx))))
|
|
;; then use add-method
|
|
;; (printf ">>> ~s: add\n" (syntax-e #'name))
|
|
(syntax/loc stx (add-method name method-make))]
|
|
;; this might still be useful sometimes...
|
|
;; [(eq? 'top-level ctx)
|
|
;; ;; if top-level then use a trick: try to use an
|
|
;; (syntax/loc stx
|
|
;; (define name ; trick: try using exising generic
|
|
;; (let ([g (or (no-errors name) (generic name))])
|
|
;; (add-method g method-make)
|
|
;; g)))]
|
|
[else
|
|
;; first module or function binding
|
|
;; (printf ">>> ~s: def\n" (syntax-e #'name))
|
|
(syntax/loc stx (define name
|
|
(let ([g (generic name)])
|
|
(add-method g method-make)
|
|
g)))])))]))
|
|
|
|
;;>> (defmethod name [qualifier] (arg ...) body ...)
|
|
;;> | (defmethod [qualifier] (name arg ...) body ...)
|
|
;;> This form is used to define a method object using `method' and its
|
|
;;> variants above. A qualifier (a :keyword) can be specified anywhere
|
|
;;> before the argument list, and the name can be either specified before
|
|
;;> the arguments (Lisp style) or with the arguments (Scheme style).
|
|
;;> Depending on `-defmethod-create-generics-' (see above), this form
|
|
;;> might add a `defgeneric' form to define the given `name' as a generic
|
|
;;> object, and then add the created method. The created method is
|
|
;;> attached to the generic in any case, which makes the name of this form
|
|
;;> a little misleading since it is not always defining a variable value.
|
|
;;> In a local definition context, this should do the right thing as long
|
|
;;> as `defmethod' or `defgeneric' is used to define the method (but note
|
|
;;> that using a local generic function, is very inefficient) -- for
|
|
;;> example, both of these work (defining a local generic):
|
|
;;> (define (f)
|
|
;;> (defgeneric foo)
|
|
;;> (defmethod (foo [x <c1>]) 1)
|
|
;;> (defmethod (foo [x <c2>]) 2)
|
|
;;> 3)
|
|
;;> (define (f)
|
|
;;> (defmethod (foo [x <c1>]) 1)
|
|
;;> (defmethod (foo [x <c2>]) 2)
|
|
;;> 3)
|
|
;;> but this fails because the first `defmethod' doesn't know that it is
|
|
;;> already defined:
|
|
;;> (define (f)
|
|
;;> (define foo (generic foo))
|
|
;;> (defmethod (foo [x c1]) 1)
|
|
;;> (defmethod (foo [x c1]) 2)
|
|
;;> 3)
|
|
;;> second "but" -- this:
|
|
;;> (define (f)
|
|
;;> (define foo (generic foo))
|
|
;;> blah
|
|
;;> (defmethod (foo [x <c1>]) 1)
|
|
;;> (defmethod (foo [x <c2>]) 2)
|
|
;;> 3)
|
|
;;> works because a `defmethod' in an expression context is always the
|
|
;;> same as `add-method'.
|
|
(defsyntax* (defmethod stx)
|
|
(define (n+a? stx)
|
|
(let ([na (syntax-e stx)]) (and (pair? na) (identifier? (car na)))))
|
|
(syntax-case stx ()
|
|
[(_ name qualifier args body0 body ...)
|
|
(and (identifier? #'name) (syntax-keyword? #'qualifier))
|
|
(syntax/loc stx
|
|
(method-def-adder qualifier name args body0 body ...))]
|
|
[(_ qualifier name args body0 body ...)
|
|
(and (identifier? #'name) (syntax-keyword? #'qualifier))
|
|
(syntax/loc stx
|
|
(method-def-adder qualifier name args body0 body ...))]
|
|
[(_ qualifier name+args body0 body ...)
|
|
(and (n+a? #'name+args) (syntax-keyword? #'qualifier))
|
|
;; simple pattern matching with (name . args) and using args won't work
|
|
;; since the destructing loses the arguments context and call-next-method
|
|
;; won't be accessible in the body.
|
|
(with-syntax ([name (car (syntax-e #'name+args))]
|
|
[args (datum->syntax-object ; hack binding context!
|
|
#'name+args
|
|
(cdr (syntax-e #'name+args))
|
|
#'name+args)])
|
|
(syntax/loc stx
|
|
(method-def-adder qualifier name args body0 body ...)))]
|
|
[(_ name+args body0 body ...) (n+a? #'name+args)
|
|
;; same as above
|
|
(with-syntax ([name (car (syntax-e #'name+args))]
|
|
[args (datum->syntax-object ; hack binding context!
|
|
#'name+args
|
|
(cdr (syntax-e #'name+args))
|
|
#'name+args)])
|
|
(syntax/loc stx
|
|
(method-def-adder #f name args body0 body ...)))]
|
|
[(_ name args body0 body ...) (identifier? #'name)
|
|
(syntax/loc stx (method-def-adder #f name args body0 body ...))]))
|
|
|
|
;;>> (beforemethod ...)
|
|
;;>> (aftermethod ...)
|
|
;;>> (aroundmethod ...)
|
|
;;>> (defbeforemethod ...)
|
|
;;>> (defaftermethod ...)
|
|
;;>> (defaroundmethod ...)
|
|
;;> These forms are shorthands that will generate a qualified method using
|
|
;;> one of the standard qualifiers.
|
|
(defsubst* (beforemethod . more) (qualified-method :before . more))
|
|
(defsubst* (aftermethod . more) (qualified-method :after . more))
|
|
(defsubst* (aroundmethod . more) (qualified-method :around . more))
|
|
(defsubst* (defbeforemethod . more) (defmethod :before . more))
|
|
(defsubst* (defaftermethod . more) (defmethod :after . more))
|
|
(defsubst* (defaroundmethod . more) (defmethod :around . more))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Class macros
|
|
|
|
;;>>... Class macros
|
|
|
|
(defsyntax (make-class-form stx)
|
|
(define (slots/initargs s/a)
|
|
(let loop ([xs s/a] [r '()])
|
|
(syntax-case xs ()
|
|
[() (values (datum->syntax-object #'s/a (reverse r) #'s/a)
|
|
#'())]
|
|
[((name . args) . more) (identifier? #'name)
|
|
(loop #'more (cons #'(list 'name . args) r))]
|
|
[(key val . more) (syntax-keyword? #'key)
|
|
(values (datum->syntax-object #'s/a (reverse r) #'s/a)
|
|
#'(key val . more))]
|
|
[(name . more) (identifier? #'name)
|
|
(loop #'more (cons #'(list 'name) r))])))
|
|
(syntax-case stx ()
|
|
[(_ metaclass cname supers . s/a)
|
|
(let*-values ([(slots initargs) (slots/initargs #'s/a)]
|
|
[(meta) (syntax-getarg initargs :metaclass #'metaclass)])
|
|
(with-syntax ([(arg ...) #`(#,@initargs
|
|
:direct-supers (list . supers)
|
|
:direct-slots (list #,@slots)
|
|
:name '#,(if (syntax-e #'cname)
|
|
#'cname (syntax-local-name)))])
|
|
(if (identifier? #'cname)
|
|
#`(rec-make (cname #,meta arg ...))
|
|
#`(make #,meta arg ...))))]))
|
|
|
|
;;>> (class [name] (super ...) slot ... class-initarg ...)
|
|
;;> Create a class object (an instance of the `*default-class-class*'
|
|
;;> parameter). An explicit name can optionally be specified explicitly.
|
|
;;> The list of superclasses are evaluated normally, so they can be any
|
|
;;> expression (as with the `method' forms). Each slot can be either a
|
|
;;> symbol, which will be used as the slot name, or a list that begins
|
|
;;> with a symbol and continues with a keyword-argument option list.
|
|
;;> Finally, more initargs for the class generation can be provided. See
|
|
;;> the `defclass' forms below for an explanation on the available slot
|
|
;;> option and class initargs. If a name is given, then `rec-make' is
|
|
;;> used, see that for a description.
|
|
(defsyntax* (class stx)
|
|
(syntax-case stx ()
|
|
[(_ name supers slot ...) (identifier? #'name)
|
|
#'(make-class-form (*default-class-class*) name supers slot ...)]
|
|
[(_ supers slot ...)
|
|
#'(make-class-form (*default-class-class*) #f supers slot ...)]))
|
|
|
|
;;>> (entityclass [name] (super) slot ... class-initarg ...)
|
|
;;> Same as the `class' form, but creates an entity class object (an
|
|
;;> instance of the `*default-entityclass-class*' parameter).
|
|
(defsyntax* (entityclass stx)
|
|
(syntax-case stx ()
|
|
[(_ name supers slot ...) (identifier? #'name)
|
|
#'(make-class-form (*default-entityclass-class*) name supers slot ...)]
|
|
[(_ supers slot ...)
|
|
#'(make-class-form (*default-entityclass-class*) #f supers slot ...)]))
|
|
|
|
;;>> (-defclass-auto-initargs- [#f/initargs])
|
|
;;> This is a syntax parameter (see above) holding either `#f' or an
|
|
;;> initargs list . If it is not `#f', `defclass' below will add its
|
|
;;> contents to the end of the given initargs (so user supplied arguments
|
|
;;> can override them). The default is `#f'.
|
|
(define-syntax-parameter* -defclass-auto-initargs- #f)
|
|
|
|
;;>> (-defclass-autoaccessors-naming- [naming-keyword])
|
|
;;> This syntax parameter holds a keyword symbol that is used in the
|
|
;;> `defclass' for the `:autoaccessors' if it is specified as `#t' or if
|
|
;;> it used due to `:auto'. See the description of the `:autoaccessors'
|
|
;;> option below for possible values. The default is `:class-slot'.
|
|
(define-syntax-parameter* -defclass-autoaccessors-naming- :class-slot)
|
|
|
|
;;>> (-defclass-accessor-mode- [mode-keyword])
|
|
;;> This syntax parameter holds a keyword symbol that is used in the
|
|
;;> `defclass' for the way accessors, readers, and writers are generated.
|
|
;;> It can be `:defmethod' for using `defmethod', `:defgeneric' for using
|
|
;;> `defgeneric' and then `add-method', `:add-method' for using
|
|
;;> `add-method', `:method' for defining an independent method, or
|
|
;;> `:procedure' for defining a simple Scheme procedure. The default is
|
|
;;> `:defmethod. This default is usually fine, but a situation where this
|
|
;;> is important is if the syntax parameter `-defmethod-create-generics-'
|
|
;;> is set to `#f' so a `defmethod' requires a prior `defgeneric' so a
|
|
;;> defclass will not work unless the generic functions are defined in
|
|
;;> advance.
|
|
(define-syntax-parameter* -defclass-accessor-mode- :defmethod)
|
|
|
|
;;>> (defclass name (super ...) slot ... class-initarg ...)
|
|
;;> This form uses the `class' form above to define a new class. See the
|
|
;;> `class' form for the syntax. Note that slot-options that are not
|
|
;;> compile-time ones (method names) are accumulated according to the
|
|
;;> class precedence list.
|
|
;;>
|
|
;;> Available slot options are:
|
|
;;> * :initarg keyword
|
|
;;> Use `keyword' in `make' to provide a value for this slot.
|
|
;;> * :initializer func
|
|
;;> Use the given function to initialize the slot -- either a thunk or a
|
|
;;> function that will be applied on the initargs given to `make'.
|
|
;;> * :initvalue value
|
|
;;> Use `value' as the default for this slot.
|
|
;;> * :reader name
|
|
;;> Define `name' (an unquoted symbol) as a reader method for this slot.
|
|
;;> * :writer name
|
|
;;> Define `name' (an unquoted symbol) as a writer method for this slot.
|
|
;;> * :accessor name
|
|
;;> Define `name' (an unquoted symbol) as an accessor method for this
|
|
;;> slot -- this means that two methods are defined: `name' and
|
|
;;> `set-name!'.
|
|
;;> * :type type
|
|
;;> Restrict this slot value to objects of the given `type'.
|
|
;;> * :lock { #t | #f | value }
|
|
;;> If specified and non-`#f', then this slot is locked. `#t' locks it
|
|
;;> permanently, but a different value works as a key: they allow setting
|
|
;;> the slot by using cons of the key and the value to set.
|
|
;;> * :allocation { :class | :instance }
|
|
;;> Specify that this slot is a normal one (`:instance', the default),
|
|
;;> or allocated per class (`:class').
|
|
;;> The specific way of creating helper methods (for readers, writers, and
|
|
;;> accessors) is determined by `-defclass-accessor-mode-' (see above).
|
|
;;>
|
|
;;> Available class options (in addition to normal ones that initialize
|
|
;;> the class slots like `:name', `:direct-slots', `:direct-supers') are:
|
|
;;> * :metaclass class
|
|
;;> create a class object which is an instance of the `class'
|
|
;;> meta-class (this means that an instance of the given meta-class
|
|
;;> should be used for creating the new class).
|
|
;;> * :autoinitargs { #t | #f }
|
|
;;> if set to `#t', make the class definition automatically generate
|
|
;;> initarg keywords from the slot names. (The keywords have the same
|
|
;;> name as the slots, eg `:foo'.)
|
|
;;> * :autoaccessors { #f | #t | :class-slot | :slot }
|
|
;;> if set to non-`#f', generate accessor methods automatically --
|
|
;;> either using the classname "-" slotname convention (`:class-slot')
|
|
;;> or just the slotname (`:slot'). If it is `#t' (or turned on by
|
|
;;> `:auto') then the default naming style is taken from the
|
|
;;> `-defclass-autoaccessors-naming-' syntax parameter. Note that for
|
|
;;> this, and other external object definitions (`:automaker' and
|
|
;;> `:autopred'), the class name is stripped of a surrounding "<>"s if
|
|
;;> any.
|
|
;;> * :automaker { #f | #t }
|
|
;;> automatically creates a `maker' function using the "make-" classname
|
|
;;> naming convention. The maker function is applied on arguments and
|
|
;;> keyword-values -- if there are n slots, then arguments after the
|
|
;;> first n are passed to `make' to create the instance, then the first
|
|
;;> n are `slot-set!'ed into the n slots. This means that it can get
|
|
;;> any number of arguments, and usually there is no point in additional
|
|
;;> keyword values (since if they initialize slots, their values will
|
|
;;> get overridden anyway). It also means that the order of the
|
|
;;> arguments depend on the *complete* list of the class's slots (as
|
|
;;> given by `class-slots'), so use caution when doing multiple
|
|
;;> inheritance (actually, in that case it is probably better to avoid
|
|
;;> these makers anyway).
|
|
;;> * :autopred { #f | #t }
|
|
;;> automatically create a predicate function using the `classname "?"'
|
|
;;> naming convention.
|
|
;;> * :default-slot-options { #f | '(keyword ...) }
|
|
;;> if specified as a quoted list, then slot descriptions are modified
|
|
;;> so the first arguments are taken as values to the specified
|
|
;;> keywords. For example, if it is `'(:type :initvalue)' then a slot
|
|
;;> description can have a single argument for `:type' after the slot
|
|
;;> name, a second argument for `:initvalue', and the rest can be more
|
|
;;> standard keyword-values. This is best set with
|
|
;;> `-defclass-auto-initargs-'
|
|
;;> * :auto { #f | #t }
|
|
;;> if specified as `#t', then all automatic behavior available above is
|
|
;;> turned on.
|
|
;; The following option is added in extra.rkt
|
|
;;> * :printer { #f | #t | procedure }
|
|
;;> if given, install a printer function. `#t' means install the
|
|
;;> `print-object-with-slots' function from "clos.rkt", otherwise, it is
|
|
;;> expected to be a function that gets an object, an escape boolean
|
|
;;> flag an an optional port (i.e, 2 or more arguments), and prints the
|
|
;;> object on the class using the escape flag to select `display'-style
|
|
;;> (`#f') or `write'-style (#t).
|
|
;;>
|
|
;;> Note that the class object is made by `class' with a name, so it is
|
|
;;> possible to use the class itself as the value of `:type' properties
|
|
;;> for a recursive class.
|
|
;;>
|
|
;;> Whenever the classname is used, it is taken from the defined name,
|
|
;;> without a surrounding "<>"s if any. Note that some of these options
|
|
;;> are processed at compile time (all method names and auto-generation of
|
|
;;> methods).
|
|
(defsyntax (make-defclass-form stx)
|
|
(syntax-case stx ()
|
|
[(_ class-maker name supers . slots0)
|
|
(identifier? #'name)
|
|
(let loop ([slots1 #'slots0] [slots2 '()])
|
|
(syntax-case slots1 ()
|
|
[(slot more ...) (not (syntax-keyword? #'slot))
|
|
(loop #'(more ...) (cons #'slot slots2))]
|
|
[(initarg ...) ; if slots1 is not null then it contains class keywords
|
|
(let* ([autoargs (let ([as ((syntax-local-value
|
|
#'-defclass-auto-initargs-))])
|
|
(and (syntax? as) (syntax-e as) as))]
|
|
[initargs (if autoargs
|
|
#`(initarg ... #,@autoargs) #'(initarg ...))]
|
|
[defmethods '()]
|
|
[sgetarg (lambda (arg . def)
|
|
(let ([a (apply syntax-getarg initargs arg def)])
|
|
(if (syntax? a) (syntax-object->datum a) a)))]
|
|
[all-auto (sgetarg :auto)]
|
|
[autoaccessors (sgetarg :autoaccessors (and all-auto #t))]
|
|
[automaker (or (sgetarg :automaker) all-auto)]
|
|
[autopred (or (sgetarg :autopred) all-auto)]
|
|
[accessor-mode (syntax-e ((syntax-local-value
|
|
#'-defclass-accessor-mode-)))]
|
|
[default-slot-options (sgetarg :default-slot-options)]
|
|
[string-name
|
|
(regexp-replace
|
|
#rx"^<(.*)>$" (symbol->string (syntax-e #'name)) "\\1")])
|
|
(define (get-defaccessor-form a-name typed-args untyped-args body)
|
|
(case accessor-mode
|
|
[(:defmethod)
|
|
#`(defmethod (#,a-name #,@typed-args) #,body)]
|
|
[(:defgeneric)
|
|
#`(begin (defgeneric (#,a-name #,@untyped-args))
|
|
(add-method #,a-name (method #,typed-args #,body)))]
|
|
[(:add-method)
|
|
#`(add-method #,a-name (method #,typed-args #,body))]
|
|
[(:method) #`(define #,a-name (method #,typed-args #,body))]
|
|
[(:procedure) #`(define (#,a-name #,@untyped-args) #,body)]
|
|
[else (error
|
|
'defclass
|
|
"bad value in -defclass-accessor-mode-: ~e"
|
|
accessor-mode)]))
|
|
(define (addreader reader sname)
|
|
(push! (get-defaccessor-form
|
|
reader #'((x name)) #'(x) #`(slot-ref x '#,sname))
|
|
defmethods))
|
|
(define (addwriter writer sname type)
|
|
(push! (get-defaccessor-form
|
|
writer #`((x name) #,(if type #`(n #,type) #'n)) #'(x n)
|
|
#`(slot-set! x '#,sname n))
|
|
defmethods))
|
|
(define (do-slot slot)
|
|
(define-values (sname args)
|
|
(syntax-case slot ()
|
|
[(sname args ...)
|
|
(values
|
|
#'sname
|
|
(cond
|
|
[(not default-slot-options) #'(args ...)]
|
|
[(and (list? default-slot-options)
|
|
(= 2 (length default-slot-options))
|
|
(memq (car default-slot-options)
|
|
'(quote quasiquote)))
|
|
(let loop ([d (cadr default-slot-options)]
|
|
[as #'(args ...)]
|
|
[r '()])
|
|
(syntax-case as ()
|
|
[(v rest ...) (pair? d)
|
|
(loop (cdr d)
|
|
#'(rest ...)
|
|
(list* #'v (car d) r))]
|
|
[_ (datum->syntax-object #'(args ...)
|
|
(append (reverse r) as)
|
|
#'(args ...))]))]
|
|
[else (raise-syntax-error
|
|
#f "bad form for :default-slot-options"
|
|
stx initargs)]))]
|
|
[sname (values #'sname #'())]))
|
|
(let ([reader (syntax-getarg args :reader)]
|
|
[writer (syntax-getarg args :writer)]
|
|
[accessor
|
|
(syntax-getarg
|
|
args :accessor
|
|
(and autoaccessors
|
|
(thunk
|
|
(if (eq? autoaccessors :slot)
|
|
sname
|
|
(datum->syntax-object
|
|
sname
|
|
(string->symbol
|
|
(concat string-name "-"
|
|
(symbol->string (syntax-e sname))))
|
|
sname)))))]
|
|
[type (syntax-getarg args :type)])
|
|
(when reader (addreader reader sname))
|
|
(when writer (addwriter writer sname type))
|
|
(when accessor
|
|
(addreader accessor sname)
|
|
(addwriter
|
|
(datum->syntax-object
|
|
accessor
|
|
(string->symbol
|
|
(concat "set-" (symbol->string (syntax-e accessor)) "!"))
|
|
accessor)
|
|
sname type))
|
|
(let loop ([as args] [res (list sname)])
|
|
(syntax-case as ()
|
|
[(keyword value more ...)
|
|
(loop #'(more ...)
|
|
(list* (if (memq (syntax-e #'keyword)
|
|
'(:reader :writer :accessor))
|
|
#''value #'value)
|
|
#'keyword res))]
|
|
[() (datum->syntax-object as (reverse res) as)]))))
|
|
(when (eq? autoaccessors #t)
|
|
(set! autoaccessors
|
|
(syntax-e ((syntax-local-value
|
|
#'-defclass-autoaccessors-naming-)))))
|
|
(unless (memq autoaccessors '(#t #f :slot :class-slot))
|
|
(raise-syntax-error
|
|
#f (concat "`:autoaccessors' expecting either a "
|
|
"`:slot' or `:class-slot' as value.")
|
|
stx initargs))
|
|
(let ([slots (map do-slot (reverse slots2))])
|
|
#`(begin
|
|
(define name
|
|
(class-maker name supers
|
|
. #,(datum->syntax-object
|
|
#'slots0
|
|
;; note: append with a non-list 2nd arg
|
|
(append
|
|
slots (if all-auto
|
|
#`(:autoinitargs #t #,@initargs)
|
|
initargs))
|
|
#'slots0)))
|
|
#,@(datum->syntax-object
|
|
#'stx (reverse defmethods) #'stx)
|
|
#,@(if automaker
|
|
(with-syntax
|
|
([maker (datum->syntax-object
|
|
#'name
|
|
(string->symbol
|
|
(concat "make-" string-name))
|
|
#'name)])
|
|
#'((define maker
|
|
(let ([slots (class-slots name)])
|
|
(lambda args
|
|
(let loop ([as args] [ss slots] [r '()])
|
|
(if (or (null? as) (null? ss))
|
|
(let ([new (make name . as)])
|
|
(for-each (lambda (x)
|
|
(slot-set! new . x))
|
|
r)
|
|
new)
|
|
(loop (cdr as) (cdr ss)
|
|
(cons (list (caar ss) (car as))
|
|
r)))))))))
|
|
'())
|
|
#,@(if autopred
|
|
(with-syntax
|
|
([pred? (datum->syntax-object
|
|
#'name
|
|
(string->symbol (concat string-name "?"))
|
|
#'name)])
|
|
#'((define (pred? x) (instance-of? x name))))
|
|
'()))))]))]))
|
|
|
|
(defsubst* (defclass name supers slot ...)
|
|
(make-defclass-form class name supers slot ...))
|
|
|
|
;;>> (defentityclass name (super ...) slot ... class-initarg ...)
|
|
;;> The same as `defclass', but for entity classes.
|
|
(defsubst* (defentityclass name supers slot ...)
|
|
(make-defclass-form entityclass name supers slot ...))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Forms with a provide version
|
|
|
|
;;>>...
|
|
;;> *** Auto provide forms
|
|
|
|
;;>> (defgeneric* ...)
|
|
;;>> (defclass* ...)
|
|
;;>> (defentityclass* ...)
|
|
;;> These forms are defined as the original version, except that the
|
|
;;> defined variable is automatically provided (made using
|
|
;;> `make-provide-syntax' above). Note that there is no version for
|
|
;;> `defmethod' since it should not be used where a single definition
|
|
;;> place is needed -- and it wouldn't make sense to have multiple
|
|
;;> `provide' forms for every `defmethod*' occurrence. Note that
|
|
;;> `defclass*' provides only the class identifier and not any
|
|
;;> automatically generated ones (accessors etc).
|
|
(provide defgeneric*) (make-provide-syntax defgeneric defgeneric*)
|
|
(provide defclass*) (make-provide-syntax defclass defclass*)
|
|
(provide defentityclass*) (make-provide-syntax defentityclass defentityclass*)
|