Fachrat Informatik - Forum

Source code

OO-Pack.rkt:2:0: module: illegal use (not at top-level) in: (module OO-pack scheme (provide create-instance instance? Root send send-msg send/safe send-msg/safe class if if-true if-false) (define (make-instance) (mcons (quote instance) (mcons #f (quote ())))) (define (instance? x) (and (mpair? x) (eq? (mcar x) (quote instance)))) (define (instance-class instance) (mcar (mcdr instance))) (define (set-instance-class! instance class) (set-mcar! (mcdr instance) class)) (define (create-instance class-maker . args) (let* ((instance (make-instance)) (class (class-maker instance))) (set-instance-class! instance class) (let ((init (get-method (quote init) instance))) (if (method? init) (with-handlers ((exn:fail:contract:arity? (lambda (exn) (raise (make-exn (string-append (format "init class ~s: " (car (send-msg instance (quote type)))) (exn-message exn)) (exn-continuation-marks exn)))))) (apply init args)) #f)) instance)) (define (make-class classname methods super-class) (cond ((not (symbol? classname)) (error "bad classname" classname)) ((not (method-list? methods)) (error "bad method list" methods)) ((not (instance? super-class)) (error "bad super-class" super-class)) (else (lambda (message) (cond ((eq? message (quote type)) (lambda () (cons classname (send-msg super-class (quote type))))) ((eq? message (quote methods)) (lambda () (remove-duplicates (append (reverse (method-names methods)) (send-msg super-class (quote methods)))))) (else (let ((entry (method-lookup message methods))) (if entry (cadr entry) (get-method message super-class))))))))) (define (class? x) (procedure? x)) (define (->class x) (cond ((instance? x) (instance-class x)) ((class? x) x) (else (raise-user-error "I don't know how to make a class from" x)))) (define (make-methods . args) (define (helper lst result) (cond ((null? lst) result) ((null? (cdr lst)) (error "unmatched method (name,proc) pair")) ((not (symbol? (car lst))) (error "invalid method name" (car lst))) ((not (procedure? (cadr lst))) (error "invalid method procedure" (cadr lst))) (else (helper (cddr lst) (cons (list (car lst) (cadr lst)) result))))) (cons (quote methods) (helper args (quote ())))) (define (method-list? methods) (and (pair? methods) (eq? (car methods) (quote methods)))) (define (method-lookup message methods) (assq message (cdr methods))) (define (method-names methods) (map car (cdr methods))) (define (Root self) (lambda (message) (cond ((eq? message (quote init)) (lambda () (quote ok))) ((eq? message (quote inspect)) (lambda () (quote ok))) ((eq? message (quote type)) (lambda () (list (quote Root)))) ((eq? message (quote show)) (lambda () (list (quote instance) (car (send-msg self (quote type)))))) ((eq? message (quote methods)) (lambda () (list (quote inspect) (quote init) (quote is-a) (quote type) (quote show) (quote methods)))) ((eq? message (quote is-a)) (lambda (type) (list? (memq type (send-msg self (quote type)))))) (else (quote NO-METHOD))))) (define (send-msg object message . args) (if (instance? object) (let ((method (with-handlers ((exn:fail:user? (lambda (exn) (error (quote send-msg) (format "expects a class object with method ~s: ~s" message object))))) (get-method message object)))) (cond ((method? method) (apply method args)) (else (error (quote send-msg) "expects class object  with method ~s: class ~s" message (car (send-msg object (quote type))))))) (error (quote send-msg) (format "expects a class object with method ~s: ~s" message object)))) (define (send-msg/safe default object message . args) (if (instance? object) (let ((method (with-handlers ((exn:fail:user? (lambda (exn) (error (quote send-msg/safe) (format "expects a class object with method ~s: ~s" message object))))) (get-method message object)))) (cond ((method? method) (apply method args)) (else default))) (error (quote send-msg) (format "expects a class object with method ~s: ~s" message object)))) (define (get-method message object) ((->class object) message)) (define (method? x) (procedure? x)) (define (remove-duplicates lst) (if (null? lst) (quote ()) (cons (car lst) (remove-duplicates (filter (lambda (x) (not (eq? x (car lst)))) lst))))) (define-syntax (if stx) (syntax-case stx (quote) ((src-if bed true) (syntax (cond (bed true)))) ((src-if bed true . false) (syntax (cond (bed true) (else . false)))))) (define-syntax (if-true stx) (syntax-case stx (quote) ((src-if bed . true) (syntax (cond (bed . true)))))) (define-syntax (if-false stx) (syntax-case stx (quote) ((src-if bed . true) (syntax (cond ((not bed) . true)))))) (define-syntax (method-expand stx) (syntax-case stx () ((_ result ()) (syntax (make-methods . result))) ((_ result (name . rest)) (syntax (method-expand ((quote name) name . result) rest))))) (define-syntax (let-expand stx) (syntax-case stx () ((_ last result () . body) (syntax (letrec (last . result) . body))) ((_ last result (first . rest) . body) (syntax (let-expand last (first . result) rest . body))))) (define-syntax (send stx) (syntax-case stx (quote) ((src-send object (quote message) . arguments) (syntax/loc stx (src-send object message . arguments))) ((src-send src-object message . arguments) (cond ((identifier? (syntax message)) (quasisyntax/loc stx (let ((object src-object)) (if (instance? object) (let ((method (get-method (quote message) object))) (cond ((method? method) (unsyntax (syntax/loc stx (method . arguments)))) (else (raise-syntax-error (quote send) (format "expects class object with method ~s: <#class ~s>" (quote message) (car (send-msg object (quote type)))) (syntax (unsyntax (syntax/loc stx send))))))) (raise-syntax-error (quote send) (format "expects class object with method ~s: ~s" (quote message) object) (syntax (unsyntax (syntax/loc stx send)))))))) (else (raise-syntax-error #f "expected an message identifier" stx (syntax message))))))) (define-syntax (send/safe stx) (syntax-case stx (quote) ((src-send default object (quote message) . arguments) (syntax/loc stx (src-send default object message . arguments))) ((src-send default src-object message . arguments) (cond ((identifier? (syntax message)) (quasisyntax/loc stx (let ((object src-object)) (if (instance? object) (let ((method (get-method (quote message) object))) (cond ((method? method) (unsyntax (syntax/loc stx (method . arguments)))) (else default))) (raise-syntax-error (quote send) (format "expects class object with method ~s: ~s" (quote message) object) (syntax (unsyntax (syntax/loc stx send)))))))) (else (raise-syntax-error #f "expected an message identifier" stx (syntax message))))))) (define-syntax (class ...