diff options
Diffstat (limited to 'yasyn.scm')
| -rw-r--r-- | yasyn.scm | 253 |
1 files changed, 130 insertions, 123 deletions
@@ -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>)) +) ) ) |