some things

bin/pre.slime

@@ -1,18 +1,24 @@
 (define-syntax when (condition :rest body)
-  (list 'if condition (pair 'prog body) nil))
+  ;; (break)
+  `(if ,condition ,(pair prog body) nil))
+  ;; (list 'if condition (pair 'prog body) nil))
 
 (define-syntax unless (condition :rest body)
-  (list 'if condition nil (pair 'prog body)))
+  `(if ,condition nil ,(pair prog body)))
 
 (define-syntax defun (name arguments :rest body)
   ;; (type-assert arguments :pair)
   ;; `(define ,name (lambda ,arguments ,body))
 
+  ;; TODO(Felix: I think we do not need to wrap the body of the lamba
+  ;; in a prog
+
   ;; see if we have a docstring
   (if (and (= (type (first body)) :string) (not (= (type (rest body)) :nil)))
       (list 'define name (list 'lambda arguments (first body) (pair 'prog (rest body))))
     (list 'define name (list 'lambda arguments (pair 'prog body)))))
 
+
 (define-syntax defspecial (name arguments :rest body)
   ;; (type-assert arguments :pair)
   ;; `(define ,name (lambda ,arguments ,body))
@@ -52,7 +58,7 @@
 
 (defun pair? (x)
   "Checks if the argument is a pair."
-  (or (= (type x) :pair) (= (type x) :nil)))
+  (= (type x) :pair))
 
 (defun string? (x)
   "Checks if the argument is a string."
@@ -191,6 +197,11 @@ added to a list, which in the end is returned."
               (filter fun (rest seq)))
       (filter fun (rest seq)))))
 
+(defun zip (l1 l2)
+  (if (and (nil? l1) (nil? l2))
+      nil
+    (pair (list (first l1) (first l2)) (zip (rest l1) (rest l2)))))
+
 (defun printf (:keys sep :defaults-to " " end :defaults-to "\n" :rest args)
   "A wrapper for the built-in (print) that accepts a variable number
 of arguments and also provides keywords for specifying the printed
@@ -208,5 +219,5 @@ las argument."
 
   (eval (pair printf-quoted (extend (list :@sep (eval sep) :@end (eval end)) args))))
 
-;; (defmacro pe (@expr)
-;;   (printf @expr "evaluates to" (eval @expr)))
+(defspecial pe (@expr)
+  (printf @expr "evaluates to" (eval @expr)))

bin/test.slime

@@ -1,80 +1,77 @@
-;; (define-syntax defclass (name members :rest functions)
-;;   (list 'defun (string->symbol (concat-strings "make-" (symbol->string name)))
+(define-syntax defclass (name members :rest body)
+  "Macro for creatating classes."
+  (defun underscore (sym)
+    (string->symbol (concat-strings "_" (symbol->string sym))))
+
+  (define underscored-members (map underscore members))
+
+  ;; the wrapping let environment
+  (define let-body (list 'let (zip members underscored-members)))
+
+  ;; the body
+  (map (lambda (fun) (append let-body fun)) body)
+
+  ;; the dispatch function
+  (append let-body (list 'special-lambda '(message :rest args)
+                         "This is the docs for the handle"
+                         '(eval (extend (list message) args))))
 
 
-;;         ))
+  ;; stuff it all in the constructor function
+  (eval (list 'defun (string->symbol (concat-strings "make-" (symbol->string name))) underscored-members
+              "This is the handle to an object of the class "
+              let-body)))
 
-;; (defclass vector3 (x y z)
-;;   ;; getters and setters will be auto generated
+;; (v1 print)
+;; (v1 length)
+;; (v1 get-x)
+;; (v1 set-x 10)
 
-;;   (defun ->length ()
-;;     (** (+ (* x x) (* y y) (* z z)) 0.5))
+(defclass vector3 (x y z)
+  (defun get-x () x)
+  (defun get-y () y)
+  (defun get-z () z)
 
-;;   (defun ->scale (fac)
-;;     (mutate x (* fac x))
-;;     (mutate y (* fac y))
-;;     (mutate z (* fac z)))
+  (defun set-x  (new-x) (mutate x new-x))
+  (defun set-y  (new-y) (mutate y new-y))
+  (defun set-z  (new-z) (mutate z new-z))
 
-;;   )
+  (defun length ()
+    (** (+ (* x x) (* y y) (* z z)) 0.5))
 
-(defun make-vector3 (x-coord y-coord z-coord)
-  (let ((x x-coord)
-        (y y-coord)
-        (z z-coord))
+  (defun scale (fac)
+    (mutate x (* fac x))
+    (mutate y (* fac y))
+    (mutate z (* fac z))
+    fac)
 
-    (defun ->get-x  () x)
-    (defun ->get-y  () y)
-    (defun ->get-z  () z)
-    (defun ->set-x  (new-x) (mutate x new-x))
-    (defun ->set-y  (new-y) (mutate y new-y))
-    (defun ->set-z  (new-z) (mutate z new-z))
+  (defun add (other)
+    (make-vector3
+     (+ x (other get-x))
+     (+ y (other get-y))
+     (+ z (other get-z))))
 
-    (defun ->length ()
-      (** (+ (* x x) (* y y) (* z z)) 0.5))
+  (defun subtract (other)
+    (make-vector3
+     (- x (other get-x))
+     (- y (other get-y))
+     (- z (other get-z))))
 
-    (defun ->scale (fac)
-      (mutate x (* fac x))
-      (mutate y (* fac y))
-      (mutate z (* fac z)))
+  (defun scalar-product (other)
+    (+ (* x (other get-x))
+       (* y (other get-y))
+       (* z (other get-z))))
 
-    (defun ->print ()
-      (print "[vector3] (")
-      (print x)
-      (print " ")
-      (print y)
-      (print " ")
-      (print z)
-      (print ")\n"))
+  (defun 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)))))
 
-    (defun ->+ (other)
-      (make-vector
-       (+ x ((other ->get-x)))
-       (+ y ((other ->get-y)))
-       (+ z ((other ->get-z)))))
-
-    (defun ->- (other)
-      (make-vector
-       (- x ((other ->get-x)))
-       (- y ((other ->get-y)))
-       (- z ((other ->get-z)))))
-
-    (defun ->scalar-product (other)
-      (+ (* x ((other ->get-x)))
-         (* y ((other ->get-y)))
-         (* z ((other ->get-z)))))
-
-    (defun ->cross-product (other)
-      (make-vector
-       (- (* y ((other ->get-z))) (* z ((other ->get-y))))
-       (- (* z ((other ->get-x))) (* x ((other ->get-z))))
-       (- (* x ((other ->get-y))) (* y ((other ->get-x))))))
-
-    (special-lambda (message) (eval message))))
+  (defun printout ()
+    (printf "[vector3] (" x  y  z ")"))
+  )
 
 (define v1 (make-vector3 1 2 3))
 (define v2 (make-vector3 3 2 1))
 
-(print ((v1 ->length)))
-(print ((v2 ->length)))
-
-(read " ")