Author: yamakenz
Date: Sun Mar 30 13:12:31 2008
New Revision: 5372
Modified:
trunk/scm/light-record.scm
trunk/scm/wlos.scm
Log:
* scm/light-record.scm
- (%define-record-generic): Removed
- (%define-record-getter, %define-record-setter): New macro
- (define-record-generic): Merge %define-record-generic
- (define-vector-record, define-list-record, define-record):
Follow the changes
* scm/wlos.scm
- (make-class-object-name, %define-class): Removed
- (%define-methods): New macro
- (define-class): Merge %define-class
Modified: trunk/scm/light-record.scm
==============================================================================
--- trunk/scm/light-record.scm (original)
+++ trunk/scm/light-record.scm Sun Mar 30 13:12:31 2008
@@ -54,7 +54,7 @@
;; <list2record> <record-copy>
;; <record-ref> <record-set!>)
;;
-;; <record name> ::= <symbol>
+;; <record name> ::= <identifier>
;; <list2record> ::= <procedure>
;; <record-copy> ::= <procedure>
;; <record-ref> ::= <procedure>
@@ -171,49 +171,61 @@
(record-set! rec index val))))
(%retrieve-record-accessor index setter))))
-(define %define-record-generic
- (lambda (rec-name fld-specs list->record record-copy record-ref record-set!)
- ;; define record field specs
- (eval `(define ,(make-record-spec-name rec-name) ',fld-specs)
- (interaction-environment))
- ;; define record object constructor
- (let ((constructor-name (make-record-constructor-name rec-name))
- (constructor (%make-record-constructor
- rec-name fld-specs list->record)))
- (eval `(define ,constructor-name ,constructor)
- (interaction-environment)))
- ;; define record object duplicator
- (eval `(define ,(make-record-duplicator-name rec-name) ,record-copy)
- (interaction-environment))
- ;; define record field accessors
- (for-each (lambda (fld-name index)
- (let ((getter-name (make-record-getter-name rec-name fld-name))
- (getter (%make-record-getter index record-ref))
- (setter-name (make-record-setter-name rec-name fld-name))
- (setter (%make-record-setter index record-set!)))
- (eval `(define ,getter-name ,getter)
- (interaction-environment))
- (eval `(define ,setter-name ,setter)
- (interaction-environment))))
- (map record-field-spec-name fld-specs)
- (iota (length fld-specs)))))
+(define-macro %define-record-getter
+ (lambda (rec-name fld-name index record-ref)
+ (let ((getter-name (make-record-getter-name rec-name fld-name))
+ (getter (%make-record-getter index record-ref)))
+ `(define ,getter-name ,getter))))
+
+(define-macro %define-record-setter
+ (lambda (rec-name fld-name index record-set!)
+ (let ((setter-name (make-record-setter-name rec-name fld-name))
+ (setter (%make-record-setter index record-set!)))
+ `(define ,setter-name ,setter))))
+
+;;(define-macro %define-record-accessors
+;; (lambda (rec-name fld-specs record-ref record-set!)
+;; (cons 'begin
+;; (map (lambda (fld-name index)
+;; `(begin
+;; (%define-record-getter ,rec-name ,fld-name ,index
+;; ,record-ref)
+;; (%define-record-setter ,rec-name ,fld-name ,index
+;; ,record-set!)))
+;; (map record-field-spec-name fld-specs)
+;; (iota (length fld-specs))))))
(define-macro define-record-generic
(lambda (rec-name fld-specs list->record record-copy record-ref record-set!)
- `(%define-record-generic
- ',rec-name ,fld-specs
- ,list->record ,record-copy ,record-ref ,record-set!)))
+ `(begin
+ ;; define record field specs
+ (define ,(make-record-spec-name rec-name) ,fld-specs)
+ ;; define record object constructor
+ (define ,(make-record-constructor-name rec-name)
+ (%make-record-constructor ',rec-name ,fld-specs ,list->record))
+ ;; define record object duplicator
+ (define ,(make-record-duplicator-name rec-name) ,record-copy)
+ ;; define record field accessors
+ (cons 'begin
+ ,(map (lambda (fld-name index)
+ `(begin
+ (%define-record-getter ,rec-name ,fld-name ,index
+ ,record-ref)
+ (%define-record-setter ,rec-name ,fld-name ,index
+ ,record-set!)))
+ (map record-field-spec-name (eval fld-specs
(interaction-environment)))
+ (iota (length (eval fld-specs
(interaction-environment)))))))))
(define-macro define-vector-record
(lambda (rec-name fld-specs)
- `(%define-record-generic
- ',rec-name ,fld-specs
- list->vector vector-copy vector-ref vector-set!)))
+ `(define-record-generic
+ ,rec-name ,fld-specs
+ list->vector vector-copy vector-ref vector-set!)))
(define-macro define-list-record
(lambda (rec-name fld-specs)
- `(%define-record-generic
- ',rec-name ,fld-specs
+ `(define-record-generic
+ ,rec-name ,fld-specs
list-copy list-copy list-ref %list-set!)))
;; Backward compatibility
@@ -223,7 +235,7 @@
;; (e.g. (list-ref spec 2) and so on may be used)
(define define-record
(lambda (rec-name fld-specs)
- (eval `(define-list-record ,rec-name ',fld-specs)
+ (eval `(define-list-record ,rec-name ,fld-specs)
(interaction-environment))
(let ((constructor-name (make-record-constructor-name rec-name))
(legacy-constructor-name (symbol-append rec-name %HYPHEN-SYM 'new)))
Modified: trunk/scm/wlos.scm
==============================================================================
--- trunk/scm/wlos.scm (original)
+++ trunk/scm/wlos.scm Sun Mar 30 13:12:31 2008
@@ -185,10 +185,6 @@
(lambda (klass method-name proc)
`(%class-set-method! ,klass ',method-name ,proc)))
-(define make-class-object-name
- (lambda (class-name)
- class-name))
-
(define %make-class
(lambda (super fld-specs+ method-names+)
(let ((ancestors (if (eq? super class) ;; bootstrap
@@ -205,37 +201,34 @@
(class-set-method-names! klass method-names)
klass)))
-(define %define-class
- (lambda (name super fld-specs+ method-names+)
- (let ((klass (%make-class super fld-specs+ method-names+)))
- ;; define class object
- (eval `(define ,(make-class-object-name name) ',klass)
- (interaction-environment))
- ;; define instance structure as record
- ;; FIXME: hardcoded define-vector-record
- (eval `(define-vector-record ,name ',(class-field-specs klass))
- (interaction-environment))
- ;; redefine record object constructor as accepting class-less args
- (let* ((constructor-name (make-record-constructor-name name))
- (orig-constructor (symbol-value constructor-name))
- (constructor (lambda args
- (apply orig-constructor (cons klass args)))))
- (eval `(define ,constructor-name ,constructor)
- (interaction-environment)))
- ;; define method dispatchers
- ;; overwrites <class>-copy defined by define-*-record
- (for-each (lambda (method-name)
- (let ((dispatcher-name
- (make-method-dispatcher-name name method-name))
- (dispatcher
- (make-method-dispatcher klass method-name)))
- (eval `(define ,dispatcher-name ,dispatcher)
- (interaction-environment))))
- (vector->list (class-method-names klass))))))
+(define-macro %define-methods
+ (lambda (klass-name method-names)
+ (cons 'begin
+ (map (lambda (method-name)
+ `(define ,(make-method-dispatcher-name klass-name method-name)
+ (make-method-dispatcher ,klass-name ',method-name)))
+ method-names))))
(define-macro define-class
(lambda (name super fld-specs+ method-names+)
- `(%define-class ',name ,super ,fld-specs+ ,method-names+)))
+ (let ((klass (apply %make-class
+ (eval `(list ,super ,fld-specs+ ,method-names+)
+ (interaction-environment)))))
+ `(begin
+ ;; define class object
+ (define ,name ',klass)
+ ;; define instance structure as record
+ ;; FIXME: hardcoded define-vector-record
+ (define-vector-record ,name (class-field-specs ',klass))
+ ;; redefine record object constructor as accepting class-less args
+ (define ,(make-record-constructor-name name)
+ (let ((orig-constructor ,(make-record-constructor-name name)))
+ (lambda args
+ (apply orig-constructor (cons ',klass args)))))
+ ;; define method dispatchers
+ ;; overwrites <class>-copy defined by define-*-record
+ (%define-methods ,name ,(vector->list (class-method-names klass)))))))
+
;;
;; method call
