Changeset 8679 in project


Ignore:
Timestamp:
02/23/08 16:49:31 (12 years ago)
Author:
svnwiki
Message:

Changes applied for Anonymous (71.38.23.88) through svnwiki:

File:
1 edited

Legend:

Unmodified
Added
Removed
  • wiki/yasos

    r8678 r8679  
    1 yasos
    2 
    3 "Yet another Scheme Object System"
    4 
    5 Description:
     1[[tags: egg]]
     2
     3== yasos ("Yet another Scheme Object System")
     4
     5[[toc:]]
     6
     7=== Description
    68
    79A very simple OOP system with multiple inheritance, that allows mixing of styles and separates interface from implementation. There are no classes, no meta-anything, simply closures.
    810
    9 Author:
     11=== Author
    1012
    1113Kenneth Dickey
     
    1315ported to CHICKEN by Juergen Lorenz
    1416
    15 Version:
     17=== Version
    1618
    1719 1.0
    18 Usage:
     20
     21=== Usage
    1922
    2023(require-extension syntax-case yasos)
    2124
    22 Download:
     25=== Download
    2326
    2427yasos.egg
    2528
    26 Documentation:
     29=== Documentation:
    2730
    2831 (define-operation (opname self arg ...) default-body)
     
    3134 (object-with-ancestors ((ancestor1 init1) ...) operation ...)
    3235 (operate-as component operation self arg ...)
    33 Examples:
    34 
    35 ;;;===============
    36 ;;;file yasos-examples.scm
    37 ;;;===============
    38 
    39 (declare (unit yasos-examples))
    40 (require-extension syntax-case yasos format)
    41 
    42 ;;----------------------------
    43 ;; general operations
    44 ;;----------------------------
    45 
    46 (define-operation (print-obj obj port)
    47   (format port
    48     ;; if an instance does not have a print-obj operation..
    49     (if (instance? obj) "#<INSTANCE>~%" "#<NOT-AN-INSTANCE: ~s>~%") obj))
    50 
    51 (define-operation (size-obj obj)
    52   ;; default behavior
    53   (cond
    54     ((vector? obj) (vector-length obj))
    55     ((list? obj) (length obj))
    56     ((pair? obj) 2)
    57     ((string? obj) (string-length obj))
    58     ((char? obj) 1)
    59     (else
    60       (error "Operation not supported: size-obj" obj))))
    61 
    62 ;;----------------------
    63 ;; point interface
    64 ;;----------------------
    65 
    66 (define-predicate point?) ;; answers #f  by default
    67 (define-operation (x obj))
    68 (define-operation (y obj))
    69 (define-operation (set-x! obj new-x))
    70 (define-operation (set-y! obj new-y))
    71 
    72 ;;--------------------------------
    73 ;; point implementation
    74 ;;--------------------------------
    75 
    76 (define (make-point the-x the-y)
    77   (object
    78     ((point? self) #t) ;; yes, this is a point object
    79     ((x self) the-x)
    80     ((y self) the-y)
    81     ((set-x! self val)
    82       (set! the-x val)
    83       the-x)
    84     ((set-y! self val)
    85       (set! the-y val)
    86       the-y)
    87     ((size-obj self) 2)
    88     ((print-obj self port)
    89       (format port "#<point: ~a ~a>~%" (x self) (y self)))))
    90 
    91 ;;-----------------------------------------
    92 ;; 3D point interface additions
    93 ;;-----------------------------------------
    94 
    95 (define-predicate point-3d?) ;; #f by defualt
    96 (define-operation (z obj))
    97 (define-operation (set-z! obj new-z))
    98 
    99 ;;------------------------------------
    100 ;; 3D point implementation
    101 ;;------------------------------------
    102 
    103 (define (make-point-3d the-x the-y the-z)
    104   (object-with-ancestors ( (a-point (make-point the-x the-y)) )
    105     ((point-3d? self) #t)
    106     ((z self) the-z)
    107     ((set-z! self val) (set! the-z val) the-z)
    108     ;; override inherited size-obj and print-obj operations
    109     ((size-obj self) 3)
    110     ((print-obj self port)
    111       (format port "#<3d-point: ~a ~a ~a>~%" (x self) (y self) (z self)))))
    112 
    113 ;;;-----------------------
    114 ;; person interface
    115 ;;------------------------
    116 
    117 (define-predicate person?)
    118 (define-operation (name obj))
    119 (define-operation (age obj))
    120 (define-operation (set-age! obj new-age))
    121 (define-operation (ssn obj password)) ;; Social Security # is protected
    122 (define-operation (new-password obj old-passwd new-passwd))
    123 (define-operation (bad-password obj bogus-passwd)
    124   ;; assume internal (design) error
    125   (error (format #f "Bad Password: ~s given to ~a~%"
    126           bogus-passwd
    127           (print-obj obj #f))))
    128 
    129 ;;----------------------------------
    130 ;; person implementation
    131 ;;----------------------------------
    132 
    133 (define (make-person a-name an-age a-ssn the-password)
    134   (object
    135     ((person? self) #t)
    136     ((name self) a-name)
    137     ((age self) an-age)
    138     ((set-age! self val) (set! an-age val) an-age)
    139     ((ssn self password)
    140       (if (equal? password the-password)
    141         a-ssn
    142         (bad-password self password)))
    143     ((new-password self old-passwd new-passwd)
    144       (cond
    145         ((equal? old-passwd the-password) (set! the-password new-passwd) self)
    146         (else (bad-password self old-passwd))))
    147     ((bad-password self bogus-passwd)
    148       (format #t "Bad password: ~s~%" bogus-passwd)) ;; let user recover
    149     ((print-obj self port)
    150       (format port "#<Person: ~a age: ~a>~%" (name self) (age self)))))
     36
     37=== Examples
     38
     39 ;;;===============
     40 ;;;file yasos-examples.scm
     41 ;;;===============
     42
     43 (declare (unit yasos-examples))
     44 (require-extension syntax-case yasos format)
     45
     46 ;;----------------------------
     47 ;; general operations
     48 ;;----------------------------
     49
     50 (define-operation (print-obj obj port)
     51   (format port
     52     ;; if an instance does not have a print-obj operation..
     53     (if (instance? obj) "#<INSTANCE>~%" "#<NOT-AN-INSTANCE: ~s>~%") obj))
     54
     55 (define-operation (size-obj obj)
     56   ;; default behavior
     57   (cond
     58     ((vector? obj) (vector-length obj))
     59     ((list? obj) (length obj))
     60     ((pair? obj) 2)
     61     ((string? obj) (string-length obj))
     62     ((char? obj) 1)
     63     (else
     64       (error "Operation not supported: size-obj" obj))))
     65
     66 ;;----------------------
     67 ;; point interface
     68 ;;----------------------
     69
     70 (define-predicate point?) ;; answers #f  by default
     71 (define-operation (x obj))
     72 (define-operation (y obj))
     73 (define-operation (set-x! obj new-x))
     74 (define-operation (set-y! obj new-y))
     75
     76 ;;--------------------------------
     77 ;; point implementation
     78 ;;--------------------------------
     79
     80 (define (make-point the-x the-y)
     81   (object
     82     ((point? self) #t) ;; yes, this is a point object
     83     ((x self) the-x)
     84     ((y self) the-y)
     85     ((set-x! self val)
     86       (set! the-x val)
     87       the-x)
     88     ((set-y! self val)
     89       (set! the-y val)
     90       the-y)
     91     ((size-obj self) 2)
     92     ((print-obj self port)
     93       (format port "#<point: ~a ~a>~%" (x self) (y self)))))
     94
     95 ;;-----------------------------------------
     96 ;; 3D point interface additions
     97 ;;-----------------------------------------
     98
     99 (define-predicate point-3d?) ;; #f by defualt
     100 (define-operation (z obj))
     101 (define-operation (set-z! obj new-z))
     102
     103 ;;------------------------------------
     104 ;; 3D point implementation
     105 ;;------------------------------------
     106
     107 (define (make-point-3d the-x the-y the-z)
     108   (object-with-ancestors ( (a-point (make-point the-x the-y)) )
     109     ((point-3d? self) #t)
     110     ((z self) the-z)
     111     ((set-z! self val) (set! the-z val) the-z)
     112     ;; override inherited size-obj and print-obj operations
     113     ((size-obj self) 3)
     114     ((print-obj self port)
     115       (format port "#<3d-point: ~a ~a ~a>~%" (x self) (y self) (z self)))))
     116
     117 ;;;-----------------------
     118 ;; person interface
     119 ;;------------------------
     120
     121 (define-predicate person?)
     122 (define-operation (name obj))
     123 (define-operation (age obj))
     124 (define-operation (set-age! obj new-age))
     125 (define-operation (ssn obj password)) ;; Social Security # is protected
     126 (define-operation (new-password obj old-passwd new-passwd))
     127 (define-operation (bad-password obj bogus-passwd)
     128   ;; assume internal (design) error
     129   (error (format #f "Bad Password: ~s given to ~a~%"
     130           bogus-passwd
     131           (print-obj obj #f))))
     132
     133 ;;----------------------------------
     134 ;; person implementation
     135 ;;----------------------------------
     136
     137 (define (make-person a-name an-age a-ssn the-password)
     138   (object
     139     ((person? self) #t)
     140     ((name self) a-name)
     141     ((age self) an-age)
     142     ((set-age! self val) (set! an-age val) an-age)
     143     ((ssn self password)
     144       (if (equal? password the-password)
     145         a-ssn
     146         (bad-password self password)))
     147     ((new-password self old-passwd new-passwd)
     148       (cond
     149         ((equal? old-passwd the-password) (set! the-password new-passwd) self)
     150         (else (bad-password self old-passwd))))
     151     ((bad-password self bogus-passwd)
     152       (format #t "Bad password: ~s~%" bogus-passwd)) ;; let user recover
     153     ((print-obj self port)
     154       (format port "#<Person: ~a age: ~a>~%" (name self) (age self)))))
    151155
    152156;;;---------------------------------------------------------------
Note: See TracChangeset for help on using the changeset viewer.