diff --git a/step_5.rkt b/step_5.rkt new file mode 100644 index 0000000000000000000000000000000000000000..fc5d5ff1372e67e13068ff13313f96162d45c43b --- /dev/null +++ b/step_5.rkt @@ -0,0 +1,96 @@ +#lang r5rs +; Authors : Nicolas Verbois - 1366 1600 +; Nicolas Rosar - 1443 1900 +; Group F + +; In this step, we improved the error message when the receiver object is inappropriate. +; We added information to mention the receiver object. + +(define (object) + (define super 'nil) + (define self_ref #f) + (define (set-self! ref) (set! self_ref ref)) + (define (gettype) 'object) + (define (self m) + (cond ((eq? m 'type) (gettype)) + ((eq? m 'set-self!) set-self!) + (else (display "Error : Message not understood")))) + self) + +(define (color-point x y color) + (define self_ref #f) + (define super (point x y)) + (define (set-self! ref) + (begin + (set! self_ref ref) + ((super 'set-self!) ref) + )) + (define (getcolor) color) + (define (gettype) 'color-point) + (define (getinfo) (append (send super 'info) (list (getcolor)))) + (define (add cp) + (color-point (+ (super 'getx) (cp 'getx)) (+ (super 'gety) (cp 'gety)) (getcolor))) + (define (self m) + (cond ((eq? m 'get-color) getcolor) + ((eq? m 'info) getinfo) + ((eq? m 'type) gettype) + ((eq? m 'add) add) + ((eq? m 'set-self!) set-self!) + (else (super m)))) + self) + +(define (point x y) + (define self_ref #f) + (define (set-self! ref) + (begin + (set! self_ref ref) + ((super 'set-self!) ref) + )) + (define super (new object)) + (define (getx) x ) + (define (gety) y ) + (define (gettype) 'point ) + (define (getinfo)(list (send self_ref 'type) (getx) (gety))) + (define (setx value)(set! x value)) + (define (sety value)(set! y value)) + (define (add p) + (point (+ (getx) (send p 'getx)) (+ (gety) (send p 'gety)))) + (define (self m) + (cond ((eq? m 'getx) getx) + ((eq? m 'gety) gety) + ((eq? m 'type) gettype) + ((eq? m 'info) getinfo) + ((eq? m 'setx!) setx) + ((eq? m 'sety!) sety) + ((eq? m 'add) add) + ((eq? m 'child) (send self 'getcolor)) + ((eq? m 'set-self!) set-self!) + (else (super m)))) + self) + + +(define (send p m . args) + (if (procedure? p) + (cond + ((null? args) ((p m))) + (else + ((p m) (car args)) + )) + (display (list "Error : Inappropriate receiver object :" p)) ) + ) + + +(define (new object-class . class-args) + (let ((new_object (apply object-class class-args))) + (begin + (send new_object 'set-self! new_object) + new_object + ) + ) + ) + + + +(define p 5) +(display (send p 'info )) ; should display : (Inappropriate receiver object : 5)#<void> +(newline)