Upload step 5 file

step_5.rkt

+#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)