Author: yamakenz Date: Sun Mar 30 13:03:45 2008 New Revision: 5371 Added: trunk/scm/light-record.scm trunk/scm/wlos.scm Modified: trunk/scm/Makefile.am
Log: * scm/light-record.scm * scm/wlos.scm - New file * scm/Makefile.am - (SCM_FILES): Add light-record.scm wlos.scm Modified: trunk/scm/Makefile.am ============================================================================== --- trunk/scm/Makefile.am (original) +++ trunk/scm/Makefile.am Sun Mar 30 13:03:45 2008 @@ -7,7 +7,8 @@ SCM_FILES = plugin.scm im.scm im-custom.scm lazy-load.scm init.scm \ im-switcher.scm \ default.scm \ - util.scm deprecated-util.scm ichar.scm ustr.scm i18n.scm iso-639-1.scm \ + util.scm deprecated-util.scm ichar.scm light-record.scm wlos.scm \ + ustr.scm i18n.scm iso-639-1.scm \ key.scm action.scm load-action.scm \ uim-sh.scm editline.scm custom.scm custom-rt.scm \ direct.scm \ Added: trunk/scm/light-record.scm ============================================================================== --- (empty file) +++ trunk/scm/light-record.scm Sun Mar 30 13:03:45 2008 @@ -0,0 +1,231 @@ +;;; light-record.scm: Lightweight record types +;;; +;;; Copyright (c) 2007 uim Project http://code.google.com/p/uim/ +;;; +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. Neither the name of authors nor the names of its contributors +;;; may be used to endorse or promote products derived from this software +;;; without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS +;;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, +;;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR +;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;; In contrast to SRFI-9 standard, this record library features: +;; +;; - Automatic accessor name generation (but lost naming scheme +;; selectability) +;; +;; - No memory overhead on each record instance such as record marker +;; and type information (but lost type detectability) +;; +;; - Selectable data backend implementation such as vector and list. +;; List backend enables sharing some tail part between multiple +;; record instances +;; +;; - Composable field-specs (since record definers are not syntax) +;; +;; +;; Specification: +;; +;; <record definition> must be placed on toplevel env. +;; +;; <record definition> ::= (define-vector-record <record name> <field specs>) +;; | (define-list-record <record name> <field specs>) +;; | (define-record-generic <record name> <field specs> +;; <list2record> <record-copy> +;; <record-ref> <record-set!>) +;; +;; <record name> ::= <symbol> +;; <list2record> ::= <procedure> +;; <record-copy> ::= <procedure> +;; <record-ref> ::= <procedure> +;; <record-set!> ::= <procedure> +;; +;; <field specs> ::= () +;; | (<field spec> . <field specs>) +;; +;; <field spec> ::= <symbol> +;; | (<symbol>) +;; | (<symbol> <default value>) +;; +;; <default value> ::= <any Scheme object> + +(require-extension (srfi 1 23)) +;;(require-extension (srfi 43)) ;; vector-copy + +(require "util.scm") +;;(require "./util") + + +(define %HYPHEN-SYM (string->symbol "-")) + +(define %list-set! + (lambda (lst index val) + (set-car! (list-tail lst index) + val))) + +(define vector-copy + (if (symbol-bound? 'vector-copy) + vector-copy + (lambda (v) + (list->vector (vector->list v))))) + +(define record-field-spec-name + (lambda (fld-spec) + (let ((name (or (safe-car fld-spec) + fld-spec))) + (if (symbol? name) + name + (error "invalid field spec"))))) + +(define record-field-spec-default-value + (compose safe-car safe-cdr)) + +(define make-record-spec-name + (lambda (rec-name) + (symbol-append 'record-spec- rec-name))) + +(define make-record-constructor-name + (lambda (rec-name) + (symbol-append 'make %HYPHEN-SYM rec-name))) + +(define make-record-duplicator-name + (lambda (rec-name) + (symbol-append rec-name %HYPHEN-SYM 'copy))) + +(define make-record-getter-name + (lambda (rec-name fld-name) + (symbol-append rec-name %HYPHEN-SYM fld-name))) + +(define make-record-setter-name + (lambda (rec-name fld-name) + (symbol-append rec-name %HYPHEN-SYM 'set- fld-name '!))) + +(define %make-record-constructor + (lambda (rec-name fld-specs list->record) + (let ((defaults (map record-field-spec-default-value fld-specs)) + (defaults-len (length fld-specs))) + (lambda init-lst + (if (null? init-lst) + (list->record defaults) + (let ((init-lst-len (length init-lst))) + (cond + ((= init-lst-len defaults-len) + (list->record init-lst)) + ((< init-lst-len defaults-len) + (let* ((rest-defaults (list-tail defaults init-lst-len)) + (complemented-init-lst (append init-lst rest-defaults))) + (list->record complemented-init-lst))) + (else + (error "invalid initialization list for record" + rec-name))))))))) + +;; To suppress redundant closure allocation, accessors for same +;; <index, type> share identical procedure. And faster short-cut +;; procedures such as car are predefined. +(define %retrieve-record-accessor + (let ((pool `(((0 . ,list-ref) . ,car) + ((1 . ,list-ref) . ,cadr) + ((2 . ,list-ref) . ,caddr) + ((0 . ,%list-set!) . ,set-car!) + ((1 . ,%list-set!) . ,(lambda (l v) + (set-car! (cdr l) v))) + ((2 . ,%list-set!) . ,(lambda (l v) + (set-car! (cddr l) v)))))) + (lambda (index accessor) + (let ((pool-key (cons index accessor))) + (cond + ((assoc pool-key pool) => cdr) + (else + (set! pool (alist-cons pool-key accessor pool)) + accessor)))))) + +(define %make-record-getter + (lambda (index record-ref) + (let ((getter (lambda (rec) + (record-ref rec index)))) + (%retrieve-record-accessor index getter)))) + +(define %make-record-setter + (lambda (index record-set!) + (let ((setter (lambda (rec val) + (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-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!))) + +(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-macro define-list-record + (lambda (rec-name fld-specs) + `(%define-record-generic + ',rec-name ,fld-specs + list-copy list-copy list-ref %list-set!))) + +;; Backward compatibility +;; +;; See test/test-util.scm to know what define-record does. fld-specs +;; requires list of list rather than alist to keep extensibility +;; (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) + (interaction-environment)) + (let ((constructor-name (make-record-constructor-name rec-name)) + (legacy-constructor-name (symbol-append rec-name %HYPHEN-SYM 'new))) + (eval `(define ,legacy-constructor-name ,constructor-name) + (interaction-environment))))) Added: trunk/scm/wlos.scm ============================================================================== --- (empty file) +++ trunk/scm/wlos.scm Sun Mar 30 13:03:45 2008 @@ -0,0 +1,441 @@ +;;; wlos.scm: Wacky Lightweight Object System +;;; +;;; Copyright (c) 2007 uim Project http://code.google.com/p/uim/ +;;; +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. Neither the name of authors nor the names of its contributors +;;; may be used to endorse or promote products derived from this software +;;; without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS +;;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, +;;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR +;;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;; Wacky Lightweight Object System (WLOS, pronounced as wa-loss like +;; CLOS as kloss, or in Japanese, ワロス) is designed to provide less +;; resource consumptive and efficient object oriented programming +;; environment. -- YamaKen 2007-08-19 +;; +;; Characteristics of WLOS: +;; +;; - Single dispatch +;; +;; Method selection is only based on the receiver object. +;; +;; - Class-based +;; +;; All instances of a class share identical type information +;; including method table. But 'object-derive' allows making +;; singleton object and per-object method redefinition. All methods +;; listed in define-class are polymorphic. +;; +;; - Single inheritance +;; +;; Only one superclass can be inherited. Though WLOS does not have +;; multiple inheritance -like feature such as interfaces or mix-ins, +;; "call by name" methods can be used to achieve such flexibility. +;; +;; - Fixed method set +;; +;; Though method redefinition on the fly can be performed, no new +;; method can dynamically be added to a class once define-class has +;; been finished. +;; +;; - Inheritance by copy +;; +;; Even if a superclass method is redefined, the change does not +;; affect decendant classes. The method table is only copied at +;; inheritance time. +;; +;; - Call by index +;; +;; Normal method call on WLOS is performed by retrieving the method +;; by integer index to the method table, as like as vptr-based +;; method call on C++. So an inheritance is required to make a method +;; polymorphic. +;; +;; - Call by name +;; +;; In addition to the index-based method call described above, call +;; by name (method name symbol, accurately) is also supported for +;; flexible object oriented programming. 'call-method' and +;; 'call-supermethod' are provided for explicit method call, and +;; 'make-call-by-name-method-dispatcher' is for defining a method +;; dispatcher with implicit name-based call. Inheritance-less +;; polymorphism (i.e. duck typing) can be performed by them. Define +;; field-accessors as method if you want to access them without type +;; assumption. +;; +;; - No type check +;; +;; An object instance cannot be distinguished from its real data +;; type such as vector or list. And both method dispatcher and +;; method itself do not check whether the receiver object is +;; suitable for the method. Ensuring method & receiver combination +;; proper is user responsibility. +;; +;; - No information hiding +;; +;; All field accessors and methods are public. If you want to hide +;; some of them, make them inaccesible or rename to a private name. +;; +;; ;; inhibit object copy and modification of 'var' field +;; (define my-object-copy #f) +;; (define my-object-set-var! #f) +;; +;; ;; make equal? method dispatcher for my-object private +;; (define %my-object-equal? my-object-equal?) +;; (define my-object-equal? #f) +;; +;; - Alternative list-based object (not implemented yet) +;; +;; In addition to the normal vector-based object, list-based object +;; will also be able to be used to save memory consumption. The +;; list-based object will allow sharing some fields between multiple +;; objects. This feature is the main reason why WLOS is named as +;; 'wacky'. + + +(require-extension (srfi 1 23)) +;;(require-extension (srfi 43)) ;; vector-copy, vector-index, vector-append + +(require "util.scm") ;; safe-car, symbol-append +(require "ng/light-record.scm") +;;(require "./util") +;;(require "./light-record") + + +(define %HYPHEN-SYM (string->symbol "-")) + +(define vector-copy + (if (symbol-bound? 'vector-copy) + vector-copy + (lambda (v) + (list->vector (vector->list v))))) + +(define vector-index + (if (symbol-bound? 'vector-index) + vector-index + (lambda (pred v) + (list-index pred (vector->list v))))) + +(define vector-append + (if (symbol-bound? 'vector-append) + vector-append + (lambda vectors + (list->vector (append-map vector->list vectors))))) + +;; +;; class +;; + +(define-vector-record class + '((ancestors ()) ;; (super grand-super ... object) + (field-specs (class)) ;; record-spec for instance + (method-names #()))) ;; hold as vector to make call-by-name efficient + +(define class-superclass + (lambda (klass) + (or (safe-car (class-ancestors klass)) + (error "no superclass")))) + +(define class-is-a? + (lambda (klass another) + (or (eq? klass another) + (not (not (memq another (class-ancestors klass))))))) + +(define %class-method-index + (lambda (klass method-name) + (vector-index (lambda (x) + (eq? x method-name)) + (class-method-names klass)))) + +(define %class-method-field-index + (lambda (klass method-name) + (+ (vector-length class) + (%class-method-index klass method-name)))) + +(define class-find-method + (lambda (klass method-name) + (vector-ref klass (%class-method-field-index klass method-name)))) + +(define %class-set-method! + (lambda (klass method-name proc) + (vector-set! klass (%class-method-field-index klass method-name) proc))) + +(define-macro class-set-method! + (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 + '() + (cons super (class-ancestors super)))) + (fld-specs (append (class-field-specs super) fld-specs+)) + (method-names (vector-append (class-method-names super) + (list->vector method-names+))) + (klass (vector-append super (make-vector (length method-names+) + %undefined-method)))) + (set-car! fld-specs `(class ,klass)) + (class-set-ancestors! klass ancestors) + (class-set-field-specs! klass fld-specs) + (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-class + (lambda (name super fld-specs+ method-names+) + `(%define-class ',name ,super ,fld-specs+ ,method-names+))) + +;; +;; method call +;; + +(define %dispatch-method + (lambda (index self.args) + (apply (vector-ref (object-class (car self.args)) index) + self.args))) + +(define make-method-dispatcher-name + (lambda (class-name method-name) + (symbol-append class-name %HYPHEN-SYM method-name))) + +;; To suppress redundant closure allocation, dispatchers for same +;; method index share identical procedure regardless of its class. And +;; hardcoded-index version of dispatchers are predefined for efficiency. +(define make-method-dispatcher + (let ((pool `((0 . ,(lambda self.args (%dispatch-method 0 self.args))) + (1 . ,(lambda self.args (%dispatch-method 1 self.args))) + (2 . ,(lambda self.args (%dispatch-method 2 self.args))) + (3 . ,(lambda self.args (%dispatch-method 3 self.args))) + (4 . ,(lambda self.args (%dispatch-method 4 self.args))) + (5 . ,(lambda self.args (%dispatch-method 5 self.args))) + (6 . ,(lambda self.args (%dispatch-method 6 self.args))) + (7 . ,(lambda self.args (%dispatch-method 7 self.args))) + (8 . ,(lambda self.args (%dispatch-method 8 self.args))) + (9 . ,(lambda self.args (%dispatch-method 9 self.args)))))) + (lambda (klass method-name) + (let ((index (%class-method-field-index klass method-name))) + (cond + ((assv index pool) => cdr) + (else + (let ((dispatcher (lambda self.args + (%dispatch-method index self.args)))) + (set! pool (alist-cons index dispatcher pool)) + dispatcher))))))) + +;; call by name +;; To explicitly indicate that this call is name-based, method name is +;; not automatically quoted by a macro. +(define call-method + (lambda (method-name . self.args) + (apply (class-find-method (object-class (car self.args)) method-name) + self.args))) + +;; call by name +(define call-supermethod + (lambda (method-name . self.args) + (apply (class-find-method (object-superclass (car self.args)) method-name) + self.args))) + +;; Used instead of interfaces or mix-ins +;; FIXME: define proper dispatcher-redefinition way for users +(define make-call-by-name-method-dispatcher + (lambda (method-name) + (lambda self.args + (apply (class-find-method (object-class (car self.args)) method-name) + self.args)))) + +;; Method call cascading on popular OO language such as +;; +;; obj.method1(arg ...).method2(arg ...).method3 +;; +;; can be write on WLOS as folows. +;; +;; (method-fold obj `(,method1 ,arg ...) `(,method2 ,arg ...) method3 ...) +(define method-fold + (lambda (obj . method-forms) + (fold (lambda (method.args res) + (cond + ((procedure? method.args) + (method.args res)) + ((symbol? method.args) + (call-method method.args res)) + (else + (let ((method (car method.args)) + (args (cdr method.args))) + (cond + ((procedure? method) + (apply method (cons res args))) + ((symbol? method) + (apply call-method (cons* method res args))) + (else + (error "invalid method form"))))))) + obj method-forms))) + +(define %undefined-method + (lambda (self . args) + (error "undefined method"))) + + +;; +;; object +;; + +;; bootstrap +(define class (make-class)) +(set! make-class #f) +(set! class-copy #f) + +;; root of all classes +(define-class object class + ;; field specs + '() + ;; method names + '(equal? + copy)) ;; intentionally overwrites copy procedure defined by define-record + +(class-set-method! object equal? equal?) +(class-set-method! object copy vector-copy) + +(define object-superclass + (lambda (self) + (class-superclass (object-class self)))) + +(define object-is-a? + (lambda (self klass) + (class-is-a? (object-class self) klass))) + +;; Makes singleton object which allows per-object method redefinition. +;; +;; (define singleton (object-derive obj)) +;; (class-set-method! (object-class singleton) 'method-name method) +(define object-derive + (lambda (self) + (let ((derived (object-copy self)) + (singleton-class (vector-copy (object-class self)))) + (object-set-class! derived singleton-class) + derived))) + + +;; +;; Examples +;; + +(define-class comparable object + '() + '(< + <= + > + >=)) + +(define-class comparable-number-str comparable + '(value) + '()) + +(define make-comparable-number-str-compare + (lambda (compare) + (lambda (self other) + (compare (string->number (comparable-number-str-value self)) + (string->number (comparable-number-str-value other)))))) + +(class-set-method! comparable-number-str equal? + (make-comparable-number-str-compare =)) + +(class-set-method! comparable-number-str < + (make-comparable-number-str-compare <)) + +(class-set-method! comparable-number-str <= + (make-comparable-number-str-compare <=)) + +(class-set-method! comparable-number-str > + (make-comparable-number-str-compare >)) + +(class-set-method! comparable-number-str >= + (make-comparable-number-str-compare >=)) + +(define ok + (lambda () + (display "OK") + (newline) + #t)) + +(define foo (make-comparable-number-str "31")) +(define bar (make-comparable-number-str "153")) + +;; call by index +(and (comparable-< foo bar) + (comparable-<= foo bar) + (comparable-> bar foo) + (comparable->= bar foo) + (not (comparable-equal? foo bar)) + (comparable-equal? foo (object-copy foo)) + (ok)) + +;; call by name +(and (call-method '< foo bar) + (call-method '<= foo bar) + (call-method '> bar foo) + (call-method '>= bar foo) + (not (call-method 'equal? foo bar)) + (call-method 'equal? foo (object-copy foo)) + (ok)) + +(require-extension (srfi 95)) +(define comparables + (map make-comparable-number-str + '("3" "-5" "13" "-1" "0" "43"))) +(define sorted (sort comparables comparable-<)) +(and (equal? '("-5" "-1" "0" "3" "13" "43") + (map comparable-number-str-value sorted)) + (ok))
