summaryrefslogtreecommitdiffstats
path: root/yasyn.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /yasyn.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'yasyn.scm')
-rw-r--r--yasyn.scm253
1 files changed, 130 insertions, 123 deletions
diff --git a/yasyn.scm b/yasyn.scm
index d711cc2..2c91523 100644
--- a/yasyn.scm
+++ b/yasyn.scm
@@ -4,91 +4,23 @@
;;; This code is in the public domain.
(require 'object)
+(require 'object->string)
+;; (define yasos:make-instance 'bogus)
(define yasos:instance? object?)
-;; Removed (define yasos:make-instance 'bogus) ;;
-;; Removed (define-syntax YASOS:INSTANCE-DISPATCHER ;; alias so compiler can inline for speed
-;; (syntax-rules () ((yasos:instance-dispatcher inst) (cdr inst))))
-;; DEFINE-OPERATION
-
-(define-syntax define-operation
- (syntax-rules ()
- ((define-operation (<name> <inst> <arg> ...) <exp1> <exp2> ...)
- ;;=>
- (define <name> (make-generic-method
- (lambda (<inst> <arg> ...) <exp1> <exp2> ...))))
-
- ((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 <name> (make-generic-predicate)))))
-
-;; OBJECT
-
-(define-syntax object
- (syntax-rules ()
- ((object ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
- ;;=>
- (let ((self (make-object)))
- (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...))
- ...
- self))))
-
-;; OBJECT with MULTIPLE INHERITANCE {First Found Rule}
-
-(define-syntax object-with-ancestors
- (syntax-rules ()
- ((object-with-ancestors ( (<ancestor1> <init1>) ... )
- ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
- ;;=>
- (let* ((<ancestor1> <init1>)
- ...
- (self (make-object <ancestor1> ...)))
- (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...))
- ...
- self))))
-
-;; OPERATE-AS {a.k.a. send-to-super}
-
-; used in operations/methods
-
-(define-syntax operate-as
- (syntax-rules ()
- ((operate-as <component> <op> <composit> <arg> ...) ;; What is <composit> ???
- ;;=>
- ((get-method <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
+(define (pormat dest arg)
+ (define obj (if (yasos:instance? arg) "#<INSTANCE>" arg))
+ (cond ((eqv? dest #t) (display obj))
+ (dest (display obj dest))
+ ((yasos:instance? arg) obj)
+ (else (object->string arg))))
+
+;@
+(define add-setter 'bogus)
+(define remove-setter-for 'bogus)
+;@
+(define setter
(let ( (known-setters (list (cons car set-car!)
(cons cdr set-cdr!)
(cons vector-ref vector-set!)
@@ -97,15 +29,15 @@
(added-setters '())
)
- (set! yasos:add-setter
+ (set! add-setter
(lambda (getter setter)
(set! added-setters (cons (cons getter setter) added-setters)))
)
- (set! yasos:remove-setter-for
+ (set! remove-setter-for
(lambda (getter)
(cond
((null? added-setters)
- (slib:error "REMOVE-SETTER-FOR: Unknown getter" getter)
+ (slib:error 'remove-setter-for 'unknown-getter getter)
)
((eq? getter (caar added-setters))
(set! added-setters (cdr added-setters))
@@ -113,7 +45,7 @@
(else
(let loop ((x added-setters) (y (cdr added-setters)))
(cond
- ((null? y) (slib:error "REMOVE-SETTER-FOR: Unknown getter"
+ ((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)))
@@ -129,8 +61,6 @@
self)
) )
-
-
(define (yasos:make-access-operation <name>)
(letrec ( (setter-dispatch
(lambda (inst . args)
@@ -149,7 +79,7 @@
(get-method inst self))
=> (lambda (method) (apply method (cons inst args)))
)
- (else (slib:error "Operation not handled" <name> inst))
+ (else (slib:error 'operation-not-handled <name> inst))
) )
)
)
@@ -157,47 +87,124 @@
self
) )
-(define-syntax define-access-operation
+;;---------------------
+;; general operations
+;;---------------------
+
+;;; if an instance does not have a PRINT operation..
+
+;;(define-operation (yasos:print obj port) (pormat port obj) )
+;@
+(define print
+ (make-generic-method
+ (lambda (obj!2 port!2)
+ (pormat port!2 obj!2))))
+
+;;; default behavior
+
+;;(define-operation (yasos:size obj)
+;; (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))))
+;@
+(define size
+ (make-generic-method
+ (lambda (obj!2)
+ (cond ((vector? obj!2) (vector-length obj!2))
+ ((list? obj!2) (length obj!2))
+ ((pair? obj!2) 2)
+ ((string? obj!2) (string-length obj!2))
+ ((char? obj!2) 1)
+ (else (slib:error 'size "Operation not supported" obj!2))))))
+
+;;; internal aliases:
+;;(define yasos:size size)
+(define yasos:setter setter)
+
+;; (define-syntax YASOS:INSTANCE-DISPATCHER
+;; ;; alias so compiler can inline for speed
+;; (syntax-rules () ((yasos:instance-dispatcher inst) (cdr inst))))
+
+;; DEFINE-OPERATION
+;@
+(define-syntax define-operation
(syntax-rules ()
- ((define-access-operation <name>)
- ;=>
- (define <name> (yasos:make-access-operation '<name>))
-) ) )
+ ((define-operation (<name> <inst> <arg> ...) <exp1> <exp2> ...)
+ ;;=>
+ (define <name> (make-generic-method
+ (lambda (<inst> <arg> ...) <exp1> <exp2> ...))))
+ ((define-operation (<name> <inst> <arg> ...) ) ;; no body
+ ;;=>
+ (define-operation (<name> <inst> <arg> ...)
+ (slib:error 'operation-not-handled
+ '<name>
+ (if (yasos:instance? <inst>) "#<INSTANCE>" <inst>))))))
+;; DEFINE-PREDICATE
+;@
+(define-syntax define-predicate
+ (syntax-rules ()
+ ((define-predicate <name>)
+ ;;=>
+ (define <name> (make-generic-predicate)))))
-;;---------------------
-;; general operations
-;;---------------------
+;; OBJECT
+;@
+(define-syntax object
+ (syntax-rules ()
+ ((object ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
+ ;;=>
+ (let ((self (make-object)))
+ (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...))
+ ...
+ self))))
-(define-operation (yasos:print obj port)
- (format port
- ;; if an instance does not have a PRINT operation..
- (if (yasos:instance? obj) "#<INSTANCE>" "~s")
- obj
-) )
+;; OBJECT with MULTIPLE INHERITANCE {First Found Rule}
+;@
+(define-syntax object-with-ancestors
+ (syntax-rules ()
+ ((object-with-ancestors ( (<ancestor1> <init1>) ... )
+ ((<name> <self> <arg> ...) <exp1> <exp2> ...) ...)
+ ;;=>
+ (let* ((<ancestor1> <init1>)
+ ...
+ (self (make-object <ancestor1> ...)))
+ (make-method! self <name> (lambda (<self> <arg> ...) <exp1> <exp2> ...))
+ ...
+ self))))
-(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))
-) )
+;; OPERATE-AS {a.k.a. send-to-super}
+
+; used in operations/methods
+;@
+(define-syntax operate-as
+ (syntax-rules ()
+ ((operate-as <component> <op> <composit> <arg> ...) ;; What is <composit> ???
+ ;;=>
+ ((get-method <component> <op>) <composit> <arg> ...))))
-(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)
+;; SET & SETTER
-(provide 'oop) ;in case we were loaded this way.
-(provide 'yasos)
+;@
+(define-syntax set
+ (syntax-rules ()
+ ((set (<access> <index> ...) <newval>)
+ ((yasos:setter <access>) <index> ... <newval>)
+ )
+ ((set <var> <newval>)
+ (set! <var> <newval>)
+ )
+) )
+;@
+(define-syntax define-access-operation
+ (syntax-rules ()
+ ((define-access-operation <name>)
+ ;=>
+ (define <name> (yasos:make-access-operation '<name>))
+) ) )