;;
;; ELM-ALIST is an alist of (symbol vector-offset-with-class . initial-value)
;; for this class only.
-;; Values can be looked up by name, via elm-make-[gs]etter routines, or
-;; methods can use elm-get/set! for speed.
+;; Values can be looked up by name, via elm-make-[gs]etter routines.
;; Various Lisp (or Lisp-like) OOP systems (e.g. CLOS, Dylan) call these
;; "slots". Maybe for consistency "slot" would be a better name. Some might
-;; confuse that with intentions at directions.
+;; confuse that with intentions at directions though.
;;
;; METHOD-ALIST is an alist of (symbol . procedure) for this class only.
;;
;;
;; -----------------------------------------------------------------------------
;;
-;; User visible procs:
+;; User visible procs/macros:
;;
-;; (class-make name parents elements methods) -> class
+;; (define-class name prefix parents members)
+;;
+;; This is a macro that defines several things:
+;; - the class object with the specified class members
+;; - a predicate to identify instances of this class, named "class?"
+;; - getters and setters for each member
+;; NAME is the name of the class.
+;; Convention requires class names to be decorated as <class-name>.
+;; ??? This might change to require the actual class object, but not yet.
+;; PREFIX is prepended to member getters/setters.
+;; PARENTS is a list of parent class names.
+;; It must contain at most one element, multiple inheritance isn't supported.
+;; Each element of MEMBERS is either member-name (for uninitialized
+;; elements) or (member-name . initial-value).
+;; MEMBER-NAME may begin with modifiers / and !:
+;; / - member is private: getter/setter begins with /
+;; ! - member is writable: readonly members do not get a setter
+;; / and ! may not appear elsewhere in MEMBER-NAME.
+;; / and ! may appear in either order.
+;;
+;; (class-make name parents members unused) -> class
;;
;; Create a class. The result is then passed back by procedures requiring
-;; a class argument. Note however that PARENTS is a list of class names,
-;; not the class data type. This allows reloading the definition of a
-;; parent class without having to reload any subclasses. To implement this
-;; classes are recorded internally, and `object-init!' must be called if any
-;; class has been redefined.
+;; a class argument.
+;; NAME is the name of the class.
+;; Convention requires class names to be decorated as <class-name>.
+;; PARENTS is a list of parent class names.
+;; It must contain at most one element, multiple inheritance isn't supported.
+;; ??? This might change to require the actual class object, but not yet.
+;; MEMBERS is a list of members, each list member is either a name (for
+;; uninitialized elements) or (name . initial-value).
+;; UNUSED must be the empty list, it will eventually be deleted.
;;
;; (class-list) -> list of all defined classes
;;
;;
;; Create a 'make! method that sets the specified elements.
;;
-;; (object-copy object) -> copy of OBJ
+;; (object-copy object) -> copy of OBJECT
+;;
+;; Return a copy of OBJECT.
+;; NOTE: This does a shallow copy.
;;
-;; ??? Whether to discard the parent or keep it and retain specialization
-;; is undecided.
+;; (object-assign! dstsrc) -> unspecified
;;
-;; (object-copy-top object) -> copy of OBJECT with spec'n discarded
+;; Assign the contents of SRC to DST.
+;; Both must be objects of the same class.
;;
;; (class? foo) -> return #t if FOO is a class
;;
;;
;; (elm-make-getter class elm-name) -> lambda
;;
-;; Return lambda to get the value of ELM-NAME in CLASS.
+;; Return efficient lambda to get the value of ELM-NAME in CLASS.
;;
;; (elm-make-setter class elm-name) -> lambda
;;
-;; Return lambda to set the value of ELM-NAME in CLASS.
+;; Return efficient lambda to set the value of ELM-NAME in CLASS.
;;
;; Conventions used in this file:
-;; - procs/vars internal to this file are prefixed with "-"
-;; [Of course this could all be put in a module; later if ever since
-;; once Guile has its own official object system we'll convert. Note that
-;; it currently does not.]
-;; - except for a few exceptions, public procs begin with one of
-;; class-, object-, elm-, method-.
-;; The exceptions are make, new, parent, send.
+;; - procs/vars internal to this file are prefixed with "/"
+;; - except for a few exceptions, public procs/macros begin with one of
+;; define-, class-, object-, elm-, method-.
+;; The exceptions are make, vmake, new, send, send-next.
+;;
+;; NOTES:
+;; - "send" as a public interface is deprecated
\f
(define /class-tag "class")
(define /object-tag "object")
(define (/object-error proc-name x . text)
(error (string-append proc-name ": "
- (apply string-append (map ->string text))
+ (apply string-append (map /object->string text))
(if (object? x)
(string-append
- " (class: " (->string (/object-class-name x))
+ " (class: " (/object->string (/object-class-name x))
(if (method-present? x 'get-name)
(string-append ", name: "
- (->string (send x 'get-name)))
+ (/object->string (send x 'get-name)))
"")
")")
"")
"")
x)
)
+
+;; Utility to count the number of non-#f elements in FLAGS.
+
+(define (/object-count-true flags)
+ (let loop ((result 0) (flags flags))
+ (if (null? flags)
+ result
+ (loop (+ result (if (car flags) 1 0))
+ (cdr flags))))
+)
+
+;; If S is a symbol, convert it to a string.
+;; Otherwise S must be a string, returned unchanged.
+
+(define (/object->string s)
+ (cond ((symbol? s) (symbol->string s))
+ ((string? s) s)
+ (else (error "not a symbol or string" s)))
+)
\f
;; Low level class operations.
;; Build the result first, then build our parents so that our parents have
;; the right value for the CHILD-BACKPOINTER field.
;; FIXME: Can't assume append! works that way.
- ;; Use a bogus value for offset for the moment.
+ ;; Use a bogus value (999) for offset for the moment.
;; The correct value is set later.
(let ((result (list class 999 child)))
;; is first instantiated.
;; ELMS is a either a list of either element names or name/value pairs.
;; Elements without initial values are marked as "unbound".
-;; METHODS is an initial alist of methods. More methods can be added with
-;; method-make!.
+;; UNUSED must be the empty list, it will eventually be deleted.
-(define (class-make name parents elms methods)
+(define (class-make name parents elms unused)
(if (> (length parents) 1)
- (/object-error 'class-make parents "multiple-inheritance is not supported"))
- (if (> (length methods) 0)
- (/object-error 'class-make methods "methods specified with class"))
+ (/object-error "class-make" parents "multiple-inheritance is not supported"))
+ (if (not (null? unused))
+ (/object-error "class-make" methods "unused parameter must be ()"))
(let ((elm-list #f))
(/object-copy obj)
)
-;; Make a copy of OBJ.
-;; This makes a copy of top level object, with any specialization discarded.
-;; WARNING: A shallow copy is done on the elements!
-;; FIXME: Delete, specialization gone.
-
-(define (object-copy-top obj)
- (/object-check obj "object-copy-top")
- (/object-copy obj)
-)
-
;; Assign object SRC to object DST.
;; They must have the same class.
(list 'quote elm) elm))
args)
'(self))))
- (method-make! class 'make! (eval1 lambda-expr))
- )
+ (method-make! class 'make! (eval1 lambda-expr)))
)
;; The "standard" way to invoke `make!' is (send (new class) 'make! ...).
(/class-subclass? (/class-name class) (/object-class object))
#f)
)
+
+;; Subroutine of define-class.
+;; Parse a define-class member list and return a list of five elements:
+;; - list of all members
+;; - list of public readable members
+;; - list of public writable members
+;; - list of private readable members
+;; - list of private writable members
+;; MEMBER-SPEC is a list of members, with private members prefixed with '/',
+;; and writable members prefixed with '!'. / and ! may appear in any order.
+;; Each element is either member-name or (member-name . initial-value).
+
+(define (/parse-member-list member-spec)
+ (let loop ((member-spec member-spec)
+ (members nil)
+ (public-readable nil)
+ (public-writable nil)
+ (private-readable nil)
+ (private-writable nil))
+ (if (null? member-spec)
+ (list (reverse! members)
+ (reverse! public-readable)
+ (reverse! public-writable)
+ (reverse! private-readable)
+ (reverse! private-writable))
+ (let* ((spec (car member-spec))
+ (sym (if (pair? spec) (car spec) spec))
+ (str (symbol->string sym)))
+ (let ((private? (string-index str #\/))
+ (writable? (string-index str #\!)))
+ ;; ??? Assumes /,! are first characters.
+ (let* ((stripped-str (substring str (/object-count-true (list private? writable?))))
+ (stripped-sym (string->symbol stripped-str)))
+ (loop (cdr member-spec)
+ ;; Combine initial value if present.
+ (cons (if (pair? spec)
+ (cons stripped-sym (cdr spec))
+ stripped-sym)
+ members)
+ (if (not private?)
+ (cons stripped-sym public-readable)
+ public-readable)
+ (if (and (not private?) writable?)
+ (cons stripped-sym public-writable)
+ public-writable)
+ (if private?
+ (cons stripped-sym private-readable)
+ private-readable)
+ (if (and private? writable?)
+ (cons stripped-sym private-writable)
+ private-writable)))))))
+)
+
+;; Subroutine of define-class.
+;; Return a list of definitions of member getters.
+
+(define (/build-getter-defs class prefix members private?)
+ (let ((str-prefix (symbol->string prefix)))
+ (cons 'begin
+ (map (lambda (m)
+ (let* ((elm-name (if (pair? m) (car m) m))
+ (name (string-append (if private? "/" "")
+ str-prefix
+ (symbol->string elm-name)))
+ (getter-name (string->symbol name)))
+ `(define ,getter-name
+ (elm-make-getter ,class (quote ,elm-name)))))
+ members)))
+)
+
+;; Subroutine of define-class.
+;; Return a list of definitions of member getters.
+
+(define (/build-setter-defs class prefix members private?)
+ (let ((str-prefix (symbol->string prefix)))
+ (cons 'begin
+ (map (lambda (m)
+ (let* ((elm-name (if (pair? m) (car m) m))
+ (name (string-append (if private? "/" "")
+ str-prefix
+ "set-"
+ (symbol->string elm-name)
+ "!"))
+ (getter-name (string->symbol name)))
+ `(define ,getter-name
+ (elm-make-setter ,class (quote ,elm-name)))))
+ members)))
+)
+
+;; Main routine to define a class.
+;;
+;; This defines several things:
+;; - the class object with the specified class members
+;; - a predicate to identify instances of this class, named "class?"
+;; - getters and setters for each member
+;;
+;; Private members are specified as /member.
+;; Writable members are specified as !member.
+;; / and ! may be combined in any order.
+;;
+;; By convention name is formatted as <class-name>.
+
+(defmacro define-class (name prefix parents members)
+ (let* ((parsed-members (/parse-member-list members))
+ (str-name (symbol->string name))
+ (str-name-len (string-length str-name))
+ (name-sans-decorations (substring str-name 1 (- str-name-len 1))))
+ ;; Enforce the <class> naming convention.
+ (if (or (not (eq? (string-ref str-name 0) #\<))
+ (not (eq? (string-ref str-name (- str-name-len 1)) #\>)))
+ (/object-error "define-class" name " not formatted as <class>: "))
+ `(begin
+ (define ,name (class-make (quote ,name) (quote ,parents) (quote ,(car parsed-members)) nil))
+ ,(/build-getter-defs name prefix (list-ref parsed-members 1) #f)
+ ,(/build-setter-defs name prefix (list-ref parsed-members 2) #f)
+ ,(/build-getter-defs name prefix (list-ref parsed-members 3) #t)
+ ,(/build-setter-defs name prefix (list-ref parsed-members 4) #t)
+ (define ,(string->symbol (string-append name-sans-decorations "?"))
+ (lambda (obj) (class-instance? ,name obj)))))
+)
\f
;; Element operations.
(let ((index (/class-lookup-element (/object-class-desc obj) elm-name)))
(if index
(not (eq? (/object-elm-get obj index) /object-unbound))
- (/object-error "elm-get" self "element not present: " elm-name)))
+ (/object-error "elm-bound?" obj "element not present: " elm-name)))
)
;; Subroutine of elm-get.
;; When the method is invoked, the (possible parent class) object in which the
;; method is found is passed to the method.
;; ??? The word `send' comes from "sending messages". Perhaps should pick
-;; a better name for this operation.
+;; a better name for this operation, except this is deprecated as a public API.
(define (send obj method-name . args)
(/object-check obj "send")
;; They could be removed with a bit of effort, but is it worth it?
;; One possibility is if method-make! was a macro, then maybe send-next could
;; work with method-make! and get the values from it.
+;;
+;; While `send' is deprecated, this is not, yet anyway.
(define (send-next obj class-name method-name . args)
(/object-check obj "send-next")
(cons obj args))
(/object-error "send-next" obj "method not supported: " method-name)))
)
-\f
-;; Miscellaneous publically accessible utilities.
-;; Reset the object system (delete all classes).
+;; Create an interface.
+;; This defines a function named NAME that invokes METHOD-NAME.
-(define (object-reset!)
- (set! /class-list (list))
- (set! /class-table (vector))
- /object-unspecified
+(defmacro define-interface (name method-name . arg-list)
+ `(define (,name object ,@arg-list)
+ (send object (quote ,method-name) ,@arg-list))
)
-;; Call once to initialize the object system.
-;; Only necessary if classes have been modified after objects have been
-;; instantiated. This usually happens during development only.
+;; Wrapper to define a method.
+;; `self' must be the first argument.
-(define (object-init!)
- (for-each (lambda (class)
- (/class-set-all-initial-values! class #f)
- (/class-set-all-methods! class #f)
- (/class-set-class-desc! class #f))
- (class-list))
- (for-each (lambda (class)
- (/class-check-init! class))
- (class-list))
- /object-unspecified
+(defmacro define-method (class name args . body)
+ `(method-make! ,class (quote ,name) ,(cons 'lambda (cons args body)))
)
+\f
+;; Miscellaneous publically accessible utilities.
;; Return list of all classes.
"not a class or object")))
)
+;; Define the getter for a list of elements of a class.
+
+(defmacro define-getters (class class-prefix elm-names)
+ (cons 'begin
+ (map (lambda (elm-name)
+ (if (pair? elm-name)
+ `(define ,(symbol-append class-prefix '- (cdr elm-name))
+ (elm-make-getter ,class (quote ,(car elm-name))))
+ `(define ,(symbol-append class-prefix '- elm-name)
+ (elm-make-getter ,class (quote ,elm-name)))))
+ elm-names))
+)
+
+;; Define the setter for a list of elements of a class.
+
+(defmacro define-setters (class class-prefix elm-names)
+ (cons 'begin
+ (map (lambda (elm-name)
+ (if (pair? elm-name)
+ `(define ,(symbol-append class-prefix '-set- (cdr elm-name) '!)
+ (elm-make-setter ,class (quote ,(car elm-name))))
+ `(define ,(symbol-append class-prefix '-set- elm-name '!)
+ (elm-make-setter ,class (quote ,elm-name)))))
+ elm-names))
+)
+
+;; Make an object, specifying values for particular elements.
+
+(define (vmake class . args)
+ (let ((obj (new class)))
+ (let ((unrecognized (send obj 'vmake! args)))
+ (if (null? unrecognized)
+ obj
+ (error "vmake: unknown options:" unrecognized))))
+)
+
;; Like assq but based on the `name' element.
;; WARNING: Slow.
(newline cep))
)
\f
-;; COS utilities.
-;; Perhaps these should be provided with cos (cgen-object-system), but for
-;; now they live here.
-
-;; Define the getter for a list of elements of a class.
-
-(defmacro define-getters (class class-prefix elm-names)
- (cons 'begin
- (map (lambda (elm-name)
- (if (pair? elm-name)
- `(define ,(symbol-append class-prefix '- (cdr elm-name))
- (elm-make-getter ,class (quote ,(car elm-name))))
- `(define ,(symbol-append class-prefix '- elm-name)
- (elm-make-getter ,class (quote ,elm-name)))))
- elm-names))
-)
-
-;; Define the setter for a list of elements of a class.
-
-(defmacro define-setters (class class-prefix elm-names)
- (cons 'begin
- (map (lambda (elm-name)
- (if (pair? elm-name)
- `(define ,(symbol-append class-prefix '-set- (cdr elm-name) '!)
- (elm-make-setter ,class (quote ,(car elm-name))))
- `(define ,(symbol-append class-prefix '-set- elm-name '!)
- (elm-make-setter ,class (quote ,elm-name)))))
- elm-names))
-)
-
-;; Make an object, specifying values for particular elements.
-;; ??? Eventually move to cos.scm/cos.c.
-
-(define (vmake class . args)
- (let ((obj (new class)))
- (let ((unrecognized (send obj 'vmake! args)))
- (if (null? unrecognized)
- obj
- (error "vmake: unknown options:" unrecognized))))
-)
-\f
;; Source locations are recorded as a stack, with (ideally) one extra level
;; for each macro invocation.
-(define <location> (class-make '<location>
- nil
- '(
- ;; A list of "single-location" objects,
- ;; sorted by most recent location first.
- list
- )
- nil))
-
-(define-getters <location> location (list))
-(define-setters <location> location (list))
+(define-class <location> location- ()
+ (
+ ;; A list of "single-location" objects,
+ ;; sorted by most recent location first.
+ !list
+ )
+)
;; A single source location.
;; This is recorded as a vector for simplicity.
;; Each named entry in the description file typically has these three members:
;; name, comment attrs.
-(define <ident> (class-make '<ident> '() '(name comment attrs) '()))
+(define-class <ident> ident- () (!name !comment !attrs))
-(method-make! <ident> 'get-name (lambda (self) (elm-get self 'name)))
-(method-make! <ident> 'get-comment (lambda (self) (elm-get self 'comment)))
-(method-make! <ident> 'get-atlist (lambda (self) (elm-get self 'attrs)))
-
-(method-make! <ident> 'set-name!
- (lambda (self newval) (elm-set! self 'name newval)))
-(method-make! <ident> 'set-comment!
- (lambda (self newval) (elm-set! self 'comment newval)))
-(method-make! <ident> 'set-atlist!
- (lambda (self newval) (elm-set! self 'attrs newval)))
-
-;; All objects defined in the .cpu file have these elements.
+;; All objects defined in the .cpu file have name, comment, attrs elements.
;; Where in the class hierarchy they're recorded depends on the object.
-;; Additionally most objects have `name', `comment' and `attrs' elements.
-
-(define (obj:name obj) (send obj 'get-name))
-(define (obj-set-name! obj name) (send obj 'set-name! name))
-(define (obj:comment obj) (send obj 'get-comment))
+;; Each object is required to provide these interfaces.
+
+(define-interface obj-name get-name)
+(define-interface obj-comment get-comment)
+;; FIXME: See definition of obj-atlist.
+(define-interface obj-atlist1 get-atlist)
+
+(define-interface obj-set-name! set-name! newval)
+(define-interface obj-set-comment! set-comment! newval)
+(define-interface obj-set-atlist! set-atlist! newval)
+
+;; Get/set attributes of OBJ.
+;; OBJ is any object which supports the get-atlist interface.
+
+(define (obj-atlist obj)
+ (let ((result (obj-atlist1 obj)))
+ ;; As a speed up, we allow objects to specify an empty attribute list
+ ;; with #f or (), rather than creating an attr-list object.
+ ;; ??? There is atlist-empty now which should be used directly, after
+ ;; which we can delete use and rename obj-atlist1 -> obj-atlist.
+ (if (or (null? result) (not result))
+ atlist-empty
+ result))
+)
+
+(define-method <ident> get-name (self)
+ (ident-name self))
+(define-method <ident> get-comment (self)
+ (ident-comment self))
+(define-method <ident> get-atlist (self)
+ (ident-attrs self))
+
+(define-method <ident> set-name! (self newval)
+ (ident-set-name! self newval))
+(define-method <ident> set-comment! (self newval)
+ (ident-set-comment! self newval))
+(define-method <ident> set-atlist! (self newval)
+ (ident-set-attrs! self newval))
+
+;; FIXME: Delete and replace with the above interfaces.
+(define (obj:name obj) (obj-name obj))
+(define (obj:comment obj) (obj-comment obj))
;; Utility to return the name as a string.
;; We can't just use the line number because we want an ordering over multiple
;; input files.
-(define <source-ident>
- (class-make '<source-ident> '(<ident>)
- '(
- ;; A <location> object.
- (location . #f)
- ;; #f for ordinal means "unassigned"
- (ordinal . #f)
- )
- '()))
-
-(method-make! <source-ident> 'get-location
- (lambda (self) (elm-get self 'location)))
-(method-make! <source-ident> 'set-location!
- (lambda (self newval) (elm-set! self 'location newval)))
-(define (obj-location obj) (send obj 'get-location))
-(define (obj-set-location! obj location) (send obj 'set-location! location))
-
-(method-make! <source-ident> 'get-ordinal
- (lambda (self) (elm-get self 'ordinal)))
-(method-make! <source-ident> 'set-ordinal!
- (lambda (self newval) (elm-set! self 'ordinal newval)))
-(define (obj-ordinal obj) (send obj 'get-ordinal))
-(define (obj-set-ordinal! obj ordinal) (send obj 'set-ordinal! ordinal))
-
-;; Return a boolean indicating if X is a <source-ident>.
-
-(define (source-ident? x) (class-instance? <source-ident> x))
+(define-class <source-ident> source-ident- (<ident>)
+ (
+ ;; A <location> object.
+ (/!location . #f)
+ ;; #f for ordinal means "unassigned"
+ (/!ordinal . #f)
+ )
+)
+
+(define-interface obj-location get-location)
+(define-interface obj-set-location! set-location! newval)
+
+(define-method <source-ident> get-location (self)
+ (/source-ident-location self))
+(define-method <source-ident> set-location! (self newval)
+ (/source-ident-set-location! self newval))
+
+(define-interface obj-ordinal get-ordinal)
+(define-interface obj-set-ordinal! set-ordinal! newval)
+
+(define-method <source-ident> get-ordinal (self)
+ (/source-ident-ordinal self))
+(define-method <source-ident> set-ordinal! (self newval)
+ (/source-ident-set-ordinal! self newval))
\f
;; Parsing utilities
;; A parsing/processing context, used to give better error messages.
;; LOCATION must be an object created with make-location.
-(define <context>
- (class-make '<context> nil
- '(
- ;; Location of the object being processed,
- ;; or #f if unknown (or there is none).
- (location . #f)
- ;; Error message prefix or #f if there is none.
- (prefix . #f)
- )
- nil)
+(define-class <context> context- ()
+ (
+ ;; Location of the object being processed,
+ ;; or #f if unknown (or there is none).
+ (location . #f)
+ ;; Error message prefix or #f if there is none.
+ (prefix . #f)
+ )
)
-;; Accessors.
-
-(define-getters <context> context (location prefix))
-
;; Create a <context> object that is just a prefix.
(define (make-prefix-context prefix)
attrs)
"\n")
)
+
;; Return C code to declare an enum of attributes ATTRS.
;; PREFIX is one of "cgen_ifld", "cgen_hw", "cgen_operand", "cgen_insn".
;; ATTRS is an alist of attribute values. The value is unimportant except that
OSDN Git Service
