diff options
author | James LewisMoss <dres@debian.org> | 1999-12-06 19:32:57 -0500 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:28 -0800 |
commit | c394920caedf3dac1981bb6b10eeb47fd6e4bb21 (patch) | |
tree | f21194653a3554f747dde3df908df993c48db5a0 /yasos.scm | |
parent | 926b1b647ac830660933a5e63eb52d4a2552e264 (diff) | |
parent | bd9733926076885e3417b74de76e4c9c7bc56254 (diff) | |
download | slib-c394920caedf3dac1981bb6b10eeb47fd6e4bb21.tar.gz slib-c394920caedf3dac1981bb6b10eeb47fd6e4bb21.zip |
Import Debian changes 2c7-1debian/2c7-1
slib (2c7-1) unstable; urgency=low
* New upstream.
* Add slibconfig back in.
slib (2c6-2) unstable; urgency=low
* Remove the slib$(VERSION).info file. Cut the diff back down to
size.
slib (2c6-1) unstable; urgency=low
* New upstream.
* Move docs to /usr/share. Up standards version. add /usr/doc symlink.
Move info files. Remove undocumented link.
slib (2c5-6) unstable; urgency=low
* Lowercase two vars in yasyn.scm (Fixes bug #37222)
slib (2c5-5) unstable; urgency=low
* Fix it so string-index isn't defined (now there is a
strsrch:string-index) (Fixes #38812)
slib (2c5-4) unstable; urgency=low
* Don't run slibconfig in postinst. (Fixes bug #38253, #37733, #37715,
#37746, #37809, #37917, #38123, #38462)
slib (2c5-3) unstable; urgency=low
* Run slibconfig in postinst. It was commented out there, but I don't
see any old bug reports on why it was commented out, so let's try
again. :) (Fixes bug #37221)
slib (2c5-2) unstable; urgency=low
* Link mklibcat.scm to mklibcat. Fixes a problem with using slib with
guile.
slib (2c5-1) unstable; urgency=low
* New upstream.
slib (2c3-4) unstable; urgency=low
* New maintainer.
Diffstat (limited to 'yasos.scm')
-rw-r--r-- | yasos.scm | 299 |
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" --- ;; |