summaryrefslogtreecommitdiffstats
path: root/yasos.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commitf24b9140d6f74804d5599ec225717d38ca443813 (patch)
tree0da952f1a5a7c0eacfc05c296766523e32c05fe2 /yasos.scm
parent8ffbc2df0fde83082610149d24e594c1cd879f4a (diff)
downloadslib-f24b9140d6f74804d5599ec225717d38ca443813.tar.gz
slib-f24b9140d6f74804d5599ec225717d38ca443813.zip
Import Upstream version 2c0upstream/2c0
Diffstat (limited to 'yasos.scm')
-rw-r--r--yasos.scm299
1 files changed, 299 insertions, 0 deletions
diff --git a/yasos.scm b/yasos.scm
new file mode 100644
index 0000000..cceea92
--- /dev/null
+++ b/yasos.scm
@@ -0,0 +1,299 @@
+; "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" --- ;;