summaryrefslogtreecommitdiffstats
path: root/yasos.scm
diff options
context:
space:
mode:
Diffstat (limited to 'yasos.scm')
-rw-r--r--yasos.scm299
1 files changed, 0 insertions, 299 deletions
diff --git a/yasos.scm b/yasos.scm
deleted file mode 100644
index cceea92..0000000
--- a/yasos.scm
+++ /dev/null
@@ -1,299 +0,0 @@
-; "YASOS.scm" Yet Another Scheme Object System
-; COPYRIGHT (c) Kenneth Dickey 1992
-;
-; This software may be used for any purpose whatever
-; without warrantee of any kind.
-; DATE 1992 March 1
-; LAST UPDATED 1992 September 1 -- misc optimizations
-; 1992 May 22 -- added SET and SETTER
-
-;; REQUIRES R^4RS Syntax System
-
-;; NOTES: A simple object system for Scheme based on the paper by
-;; Norman Adams and Jonathan Rees: "Object Oriented Programming in
-;; Scheme", Proceedings of the 1988 ACM Conference on LISP and Functional
-;; Programming, July 1988 [ACM #552880].
-;
-;; Setters use space for speed {extra conses for O(1) lookup}.
-
-
-;;
-;; INTERFACE:
-;;
-;; (DEFINE-OPERATION (opname self arg ...) default-body)
-;;
-;; (DEFINE-PREDICATE opname)
-;;
-;; (OBJECT ((name self arg ...) body) ... )
-;;
-;; (OBJECT-WITH-ANCESTORS ( (ancestor1 init1) ...) operation ...)
-;;
-;; in an operation {a.k.a. send-to-super}
-;; (OPERATE-AS component operation self arg ...)
-;;
-
-;; (SET var new-vale) or (SET (access-proc index ...) new-value)
-;;
-;; (SETTER access-proc) -> setter-proc
-;; (DEFINE-ACCESS-OPERATION getter-name) -> operation
-;; (ADD-SETTER getter setter) ;; setter is a Scheme proc
-;; (REMOVE-SETTER-FOR getter)
-;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;; IMPLEMENTATION ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; INSTANCES
-
-; (define-predicate instance?)
-; (define (make-instance dispatcher)
-; (object
-; ((instance? self) #t)
-; ((instance-dispatcher self) dispatcher)
-; ) )
-
-(define yasos:make-instance 'bogus) ;; defined below
-(define yasos:instance? 'bogus)
-(define-syntax yasos:instance-dispatcher ;; alias so compiler can inline for speed
- (syntax-rules () ((yasos:instance-dispatcher inst) (cdr inst)))
-)
-
-(let ( (instance-tag "instance") ) ;; Make a unique tag within a local scope.
- ;; No other data object is EQ? to this tag.
- (set! yasos:make-instance
- (lambda (dispatcher) (cons instance-tag dispatcher)))
-
- (set! yasos:instance?
- (lambda (obj) (and (pair? obj) (eq? (car obj) instance-tag))))
-)
-
-;; DEFINE-OPERATION
-
-
-(define-syntax define-operation
- (syntax-rules ()
- ((define-operation (<name> <inst> <arg> ...) <exp1> <exp2> ...)
- ;;=>
- (define <name>
- (letrec ( (former-inst #f) ;; simple caching -- for loops
- (former-method #f)
- (self
- (lambda (<inst> <arg> ...)
- (cond
- ((eq? <inst> former-inst) ; check cache
- (former-method <inst> <arg> ...)
- )
- ((and (yasos:instance? <inst>)
- ((yasos:instance-dispatcher <inst>) self))
- => (lambda (method)
- (set! former-inst <inst>)
- (set! former-method method)
- (method <inst> <arg> ...))
- )
- (else <exp1> <exp2> ...)
- ) ) ) )
- self)
- ))
- ((define-operation (<name> <inst> <arg> ...) ) ;; no body
- ;;=>
- (define-operation (<name> <inst> <arg> ...)
- (slib:error "Operation not handled"
- '<name>
- (format #f (if (yasos:instance? <inst>) "#<INSTANCE>" "~s")
- <inst>)))
- ))
-)
-
-
-
-;; DEFINE-PREDICATE
-
-(define-syntax define-predicate
- (syntax-rules ()
- ((define-predicate <name>)
- ;;=>
- (define-operation (<name> obj) #f)
- )
-) )
-
-
-;; OBJECT
-
-(define-syntax object
- (syntax-rules ()
- ((object ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
- ;;=>
- (let ( (table
- (list (cons <name>
- (lambda (<self> <arg> ...) <exp1> <exp2> ...))
- ...
- ) )
- )
- (yasos:make-instance
- (lambda (op)
- (cond
- ((assq op table) => cdr)
- (else #f)
-) ) )))) )
-
-
-;; OBJECT with MULTIPLE INHERITANCE {First Found Rule}
-
-(define-syntax object-with-ancestors
- (syntax-rules ()
- ((object-with-ancestors ( (<ancestor1> <init1>) ... ) <operation> ...)
- ;;=>
- (let ( (<ancestor1> <init1>) ... )
- (let ( (child (object <operation> ...)) )
- (yasos:make-instance
- (lambda (op)
- (or ((yasos:instance-dispatcher child) op)
- ((yasos:instance-dispatcher <ancestor1>) op) ...
- ) ) )
- )))
-) )
-
-
-;; OPERATE-AS {a.k.a. send-to-super}
-
-; used in operations/methods
-
-(define-syntax operate-as
- (syntax-rules ()
- ((operate-as <component> <op> <composit> <arg> ...)
- ;;=>
- (((yasos:instance-dispatcher <component>) <op>) <composit> <arg> ...)
- ))
-)
-
-
-
-;; SET & SETTER
-
-
-(define-syntax set
- (syntax-rules ()
- ((set (<access> <index> ...) <newval>)
- ((yasos:setter <access>) <index> ... <newval>)
- )
- ((set <var> <newval>)
- (set! <var> <newval>)
- )
-) )
-
-
-(define yasos:add-setter 'bogus)
-(define yasos:remove-setter-for 'bogus)
-
-(define yasos:setter
- (let ( (known-setters (list (cons car set-car!)
- (cons cdr set-cdr!)
- (cons vector-ref vector-set!)
- (cons string-ref string-set!))
- )
- (added-setters '())
- )
-
- (set! yasos:add-setter
- (lambda (getter setter)
- (set! added-setters (cons (cons getter setter) added-setters)))
- )
- (set! yasos:remove-setter-for
- (lambda (getter)
- (cond
- ((null? added-setters)
- (slib:error "REMOVE-SETTER-FOR: Unknown getter" getter)
- )
- ((eq? getter (caar added-setters))
- (set! added-setters (cdr added-setters))
- )
- (else
- (let loop ((x added-setters) (y (cdr added-setters)))
- (cond
- ((null? y) (slib:error "REMOVE-SETTER-FOR: Unknown getter"
- getter))
- ((eq? getter (caar y)) (set-cdr! x (cdr y)))
- (else (loop (cdr x) (cdr y)))
- ) ) )
- ) ) )
-
- (letrec ( (self
- (lambda (proc-or-operation)
- (cond ((assq proc-or-operation known-setters) => cdr)
- ((assq proc-or-operation added-setters) => cdr)
- (else (proc-or-operation self))) )
- ) )
- self)
-) )
-
-
-
-(define (yasos:make-access-operation <name>)
- (letrec ( (setter-dispatch
- (lambda (inst . args)
- (cond
- ((and (yasos:instance? inst)
- ((yasos:instance-dispatcher inst) setter-dispatch))
- => (lambda (method) (apply method inst args))
- )
- (else #f)))
- )
- (self
- (lambda (inst . args)
- (cond
- ((eq? inst yasos:setter) setter-dispatch) ; for (setter self)
- ((and (yasos:instance? inst)
- ((yasos:instance-dispatcher inst) self))
- => (lambda (method) (apply method inst args))
- )
- (else (slib:error "Operation not handled" <name> inst))
- ) )
- )
- )
-
- self
-) )
-
-(define-syntax define-access-operation
- (syntax-rules ()
- ((define-access-operation <name>)
- ;=>
- (define <name> (yasos:make-access-operation '<name>))
-) ) )
-
-
-
-;;---------------------
-;; general operations
-;;---------------------
-
-(define-operation (yasos:print obj port)
- (format port
- ;; if an instance does not have a PRINT operation..
- (if (yasos:instance? obj) "#<INSTANCE>" "~s")
- obj
-) )
-
-(define-operation (yasos:size obj)
- ;; default behavior
- (cond
- ((vector? obj) (vector-length obj))
- ((list? obj) (length obj))
- ((pair? obj) 2)
- ((string? obj) (string-length obj))
- ((char? obj) 1)
- (else
- (slib:error "Operation not supported: size" obj))
-) )
-
-(require 'format)
-
-;;; exports:
-
-(define print yasos:print) ; print also in debug.scm
-(define size yasos:size)
-(define add-setter yasos:add-setter)
-(define remove-setter-for yasos:remove-setter-for)
-(define setter yasos:setter)
-
-(provide 'oop) ;in case we were loaded this way.
-;; --- E O F "yasos.scm" --- ;;