(define (type-wrap obj type) (set-type obj type) obj) (define-syntax (defclass name members :rest body) "Macro for creating classes." (define (underscore sym) (string->symbol (concat-strings "_" (symbol->string sym)))) (define underscored-members (map underscore members)) ;; the wrapping let environment (define let-body `(let ,(zip members underscored-members))) ;; the body (map (lambda (fun) (append let-body fun)) body) ;; the dispatch function (append let-body `(type-wrap (special-lambda (message :rest args) "This is the docs for the handle" (eval (extend (list message) args))) ,(symbol->keyword name))) ;; stuff it all in the constructor function `(define ,(pair (string->symbol (concat-strings "make-" (symbol->string name))) underscored-members) ,(concat-strings "This is the handle to an object of the class " (symbol->string name)) ,let-body)) (defclass vector3 (x y z) (define (get-x) x) (define (get-y) y) (define (get-z) z) (define (set-x new-x) (mutate x new-x)) (define (set-y new-y) (mutate y new-y)) (define (set-z new-z) (mutate z new-z)) (define (length) (** (+ (* x x) (* y y) (* z z)) 0.5)) (define (scale fac) (mutate x (* fac x)) (mutate y (* fac y)) (mutate z (* fac z)) fac) (define (add other) (make-vector3 (+ x (other get-x)) (+ y (other get-y)) (+ z (other get-z)))) (define (subtract other) (make-vector3 (- x (other get-x)) (- y (other get-y)) (- z (other get-z)))) (define (scalar-product other) (+ (* x (other get-x)) (* y (other get-y)) (* z (other get-z)))) (define (cross-product other) (make-vector3 (- (* y (other get-z)) (* z (other get-y))) (- (* z (other get-x)) (* x (other get-z))) (- (* x (other get-y)) (* y (other get-x))))) (define (print) (printf :sep "" "[vector3] (" x y z ")")) ) (define v1 (make-vector3 1 2 3)) (define v2 (make-vector3 3 2 1)) (assert (= (type v1) (type v2) :vector3)) (assert (= (v1 scalar-product v2) 10))