From 6cf45219f15bf9d05380eb1bced6d822313c5472 Mon Sep 17 00:00:00 2001 From: Mike Cifelli Date: Tue, 7 Mar 2017 16:27:11 -0500 Subject: [PATCH] Refactor some lisp code --- lisp/lang/dlambda-test.lisp | 13 ++++++++++++ lisp/lang/dlambda.lisp | 36 +++++++++++++++++--------------- lisp/lang/functions.lisp | 8 -------- lisp/object/composition.lisp | 40 ++++++++++++++++++------------------ lisp/object/this.lisp | 29 +++++++++++++------------- lisp/unit/unit-test.lisp | 4 ++-- 6 files changed, 68 insertions(+), 62 deletions(-) diff --git a/lisp/lang/dlambda-test.lisp b/lisp/lang/dlambda-test.lisp index eb5222c..33540e8 100644 --- a/lisp/lang/dlambda-test.lisp +++ b/lisp/lang/dlambda-test.lisp @@ -28,6 +28,19 @@ (dlambda (:write () (print "something"))))) + (defun dlambda-many-named-methods () + (assert-equal + '(lambda (&rest arguments) + (case (first arguments) + (:write1 (apply (lambda () (print "something")) (rest arguments))) + (:write2 (apply (lambda () (print "something")) (rest arguments))) + (:write3 (apply (lambda () (print "something")) (rest arguments))))) + + (dlambda + (:write1 () (print "something")) + (:write2 () (print "something")) + (:write3 () (print "something"))))) + (defun dlambda-named-and-default-method () (assert-equal '(lambda (&rest arguments) diff --git a/lisp/lang/dlambda.lisp b/lisp/lang/dlambda.lisp index aafa625..ce293cc 100644 --- a/lisp/lang/dlambda.lisp +++ b/lisp/lang/dlambda.lisp @@ -1,19 +1,21 @@ (load "functions.lisp") -(define-special dlambda (&rest methods) - (cons 'lambda - (cons '(&rest arguments) - (list - (cons 'case - (cons '(first arguments) - (mapcar - (lambda (method) - (cons (first method) - (list - (cons 'apply - (cons (cons 'lambda (rest method)) - (list - (if (equal t (car method)) - 'arguments - '(rest arguments)))))))) - methods))))))) +(let + ((add-method-clause + (lambda (method) + (cons (first method) + (list + (cons 'apply + (cons (cons 'lambda (rest method)) + (list + (if (equal t (car method)) + 'arguments + '(rest arguments)))))))))) + + (define-special dlambda (&rest methods) + (cons 'lambda + (cons '(&rest arguments) + (list + (cons 'case + (cons '(first arguments) + (mapcar add-method-clause methods)))))))) diff --git a/lisp/lang/functions.lisp b/lisp/lang/functions.lisp index 3e46a98..0119aaf 100644 --- a/lisp/lang/functions.lisp +++ b/lisp/lang/functions.lisp @@ -1,8 +1,3 @@ -(defun extend-null (the-list) - (cond - ((equal (length the-list) 0) t) - (t nil))) - (defun mapcar (function-name the-list) (if the-list (cons @@ -15,9 +10,6 @@ (t (cons (funcall function-name the-list) (maplist function-name (rest the-list)))))) -(defun extend-apply (function-name param-list) - (eval (cons function-name param-list))) - (defun append (listA listB) (cond ((null listA) listB) diff --git a/lisp/object/composition.lisp b/lisp/object/composition.lisp index 22c0f89..2a12bcc 100644 --- a/lisp/object/composition.lisp +++ b/lisp/object/composition.lisp @@ -7,16 +7,16 @@ (dlambda (:inc () - (setf count (+ count 1))) + (setq count (+ count 1))) (:dec () - (setf count (- count 1))) + (setq count (- count 1))) (:get () count) (:set (value) - (setf count value)))))) + (setq count value)))))) (defun fruit-counter (initial-count) @@ -28,46 +28,46 @@ (dlambda (:inc-apples () - (funcall apple-counter :inc)) + (call apple-counter :inc)) (:dec-apples () - (funcall apple-counter :dec)) + (call apple-counter :dec)) (:get-apples () - (funcall apple-counter :get)) + (call apple-counter :get)) (:set-apples (value) - (funcall apple-counter :set value)) + (call apple-counter :set value)) (:inc-bananas () - (funcall banana-counter :inc)) + (call banana-counter :inc)) (:dec-bananas () - (funcall banana-counter :dec)) + (call banana-counter :dec)) (:get-bananas () - (funcall banana-counter :get)) + (call banana-counter :get)) (:set-bananas (value) - (funcall banana-counter :set value)) + (call banana-counter :set value)) (:inc-coconuts () - (funcall coconut-counter :inc)) + (call coconut-counter :inc)) (:dec-coconuts () - (funcall coconut-counter :dec)) + (call coconut-counter :dec)) (:get-coconuts () - (funcall coconut-counter :get)) + (call coconut-counter :get)) (:set-coconuts (value) - (funcall coconut-counter :set value)) + (call coconut-counter :set value)) (t (&rest arguments) (list - (list 'apples (funcall apple-counter :get)) - (list 'bananas (funcall banana-counter :get)) - (list 'coconuts (funcall coconut-counter :get)))))))) + (list 'apples (call apple-counter :get)) + (list 'bananas (call banana-counter :get)) + (list 'coconuts (call coconut-counter :get)))))))) ; Create an instance @@ -82,7 +82,7 @@ ; Another way ; ; usage: -; ~ (funcall my-fruits2 :set-apples 23) +; ~ (call my-fruits2 :set-apples 23) ; 23 ; -(setf my-fruits2 (fruit-counter 10000)) +(setq my-fruits2 (fruit-counter 10000)) diff --git a/lisp/object/this.lisp b/lisp/object/this.lisp index 5fcb45f..61d22f5 100644 --- a/lisp/object/this.lisp +++ b/lisp/object/this.lisp @@ -1,37 +1,36 @@ (load "../lang/dlambda.lisp") (defun counter (initial-count) - (let ((count initial-count) - (name nil) - (this nil)) + (let ((this) (name) + (count initial-count)) - (setf name "Counter") + (setq name "Counter") - (setf this + (setq this (eval (dlambda (:inc () - (setf count (+ count 1))) + (setq count (+ count 1))) (:inc-3 () - (funcall this :inc) - (funcall this :inc) - (funcall this :inc)) + (call this :inc) + (call this :inc) + (call this :inc)) (:dec () - (setf count (- count 1))) + (setq count (- count 1))) (:dec-3 () - (funcall this :dec) - (funcall this :dec) - (funcall this :dec)) + (call this :dec) + (call this :dec) + (call this :dec)) (:get () count) (:set (value) - (setf count value)) + (setq count value)) (t () (cons name count))))))) @@ -40,4 +39,4 @@ (let ((instance (counter 0))) (defun my-counter (&rest args) (apply instance args))) -(setf my-counter2 (counter 10000)) +(setq my-counter2 (counter 10000)) diff --git a/lisp/unit/unit-test.lisp b/lisp/unit/unit-test.lisp index c031e63..ef55170 100644 --- a/lisp/unit/unit-test.lisp +++ b/lisp/unit/unit-test.lisp @@ -1,5 +1,5 @@ (defun run-unit-test (unit-test) - (if (funcall unit-test) + (if (call unit-test) (progn (print (cons t unit-test)) t) @@ -18,7 +18,7 @@ (eval (cons 'and (run-test-suite test-suite)))) (defun assert (comparison expected actual) - (if (funcall comparison expected actual) + (if (call comparison expected actual) t (progn (print (list expected 'is 'not comparison actual))