From 8466d8cfa486fb30d1755c4261b781135083787b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:29 -0800 Subject: Import Upstream version 3a1 --- yasyn.scm | 253 ++++++++++++++++++++++++++++++++------------------------------ 1 file changed, 130 insertions(+), 123 deletions(-) (limited to 'yasyn.scm') 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 ( ...) ...) - ;;=> - (define (make-generic-method - (lambda ( ...) ...)))) - - ((define-operation ( ...) ) ;; no body - ;;=> - (define-operation ( ...) - (slib:error "Operation not handled" - ' - (format #f (if (yasos:instance? ) "#" "~s") - )))))) - -;; DEFINE-PREDICATE -(define-syntax define-predicate - (syntax-rules () - ((define-predicate ) - ;;=> - (define (make-generic-predicate))))) - -;; OBJECT - -(define-syntax object - (syntax-rules () - ((object (( ...) ...) ...) - ;;=> - (let ((self (make-object))) - (make-method! self (lambda ( ...) ...)) - ... - self)))) - -;; OBJECT with MULTIPLE INHERITANCE {First Found Rule} - -(define-syntax object-with-ancestors - (syntax-rules () - ((object-with-ancestors ( ( ) ... ) - (( ...) ...) ...) - ;;=> - (let* (( ) - ... - (self (make-object ...))) - (make-method! self (lambda ( ...) ...)) - ... - self)))) - -;; OPERATE-AS {a.k.a. send-to-super} - -; used in operations/methods - -(define-syntax operate-as - (syntax-rules () - ((operate-as ...) ;; What is ??? - ;;=> - ((get-method ) ...)))) - - - -;; SET & SETTER - - -(define-syntax set - (syntax-rules () - ((set ( ...) ) - ((yasos:setter ) ... ) - ) - ((set ) - (set! ) - ) -) ) - - -(define yasos:add-setter 'bogus) -(define yasos:remove-setter-for 'bogus) - -(define yasos:setter +(define (pormat dest arg) + (define obj (if (yasos:instance? arg) "#" 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 ) (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" inst)) + (else (slib:error 'operation-not-handled 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 ) - ;=> - (define (yasos:make-access-operation ')) -) ) ) + ((define-operation ( ...) ...) + ;;=> + (define (make-generic-method + (lambda ( ...) ...)))) + ((define-operation ( ...) ) ;; no body + ;;=> + (define-operation ( ...) + (slib:error 'operation-not-handled + ' + (if (yasos:instance? ) "#" )))))) +;; DEFINE-PREDICATE +;@ +(define-syntax define-predicate + (syntax-rules () + ((define-predicate ) + ;;=> + (define (make-generic-predicate))))) -;;--------------------- -;; general operations -;;--------------------- +;; OBJECT +;@ +(define-syntax object + (syntax-rules () + ((object (( ...) ...) ...) + ;;=> + (let ((self (make-object))) + (make-method! self (lambda ( ...) ...)) + ... + self)))) -(define-operation (yasos:print obj port) - (format port - ;; if an instance does not have a PRINT operation.. - (if (yasos:instance? obj) "#" "~s") - obj -) ) +;; OBJECT with MULTIPLE INHERITANCE {First Found Rule} +;@ +(define-syntax object-with-ancestors + (syntax-rules () + ((object-with-ancestors ( ( ) ... ) + (( ...) ...) ...) + ;;=> + (let* (( ) + ... + (self (make-object ...))) + (make-method! self (lambda ( ...) ...)) + ... + 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 ...) ;; What is ??? + ;;=> + ((get-method ) ...)))) -(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 ( ...) ) + ((yasos:setter ) ... ) + ) + ((set ) + (set! ) + ) +) ) +;@ +(define-syntax define-access-operation + (syntax-rules () + ((define-access-operation ) + ;=> + (define (yasos:make-access-operation ')) +) ) ) -- cgit v1.2.3