mike
/
transcendental-lisp
1
1
Fork 0
Code Issues 10 Pull Requests Packages Projects Releases Wiki Activity

Refactor some lisp code

This commit is contained in:
Mike Cifelli 2017-03-07 16:27:11 -05:00
parent 736e230de9
commit 6cf45219f1
6 changed files with 68 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
lisp/lang/dlambda-test.lisp
View File

@ -28,6 +28,19 @@
(dlambda (dlambda
(:write () (print "something"))))) (: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 () (defun dlambda-named-and-default-method ()
(assert-equal (assert-equal
'(lambda (&rest arguments) '(lambda (&rest arguments)

20
lisp/lang/dlambda.lisp
View File

@ -1,12 +1,7 @@
(load "functions.lisp") (load "functions.lisp")
(define-special dlambda (&rest methods) (let
(cons 'lambda ((add-method-clause
(cons '(&rest arguments)
(list
(cons 'case
(cons '(first arguments)
(mapcar
(lambda (method) (lambda (method)
(cons (first method) (cons (first method)
(list (list
@ -15,5 +10,12 @@
(list (list
(if (equal t (car method)) (if (equal t (car method))
'arguments 'arguments
'(rest arguments)))))))) '(rest arguments))))))))))
methods)))))))
(define-special dlambda (&rest methods)
(cons 'lambda
(cons '(&rest arguments)
(list
(cons 'case
(cons '(first arguments)
(mapcar add-method-clause methods))))))))

8
lisp/lang/functions.lisp
View File

@ -1,8 +1,3 @@
(defun extend-null (the-list)
(cond
((equal (length the-list) 0) t)
(t nil)))
(defun mapcar (function-name the-list) (defun mapcar (function-name the-list)
(if the-list (if the-list
(cons (cons
@ -15,9 +10,6 @@
(t (cons (funcall function-name the-list) (t (cons (funcall function-name the-list)
(maplist function-name (rest 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) (defun append (listA listB)
(cond (cond
((null listA) listB) ((null listA) listB)

40
lisp/object/composition.lisp
View File

@ -7,16 +7,16 @@
(dlambda (dlambda
(:inc () (:inc ()
(setf count (+ count 1))) (setq count (+ count 1)))
(:dec () (:dec ()
(setf count (- count 1))) (setq count (- count 1)))
(:get () (:get ()
count) count)
(:set (value) (:set (value)
(setf count value)))))) (setq count value))))))
(defun fruit-counter (initial-count) (defun fruit-counter (initial-count)
@ -28,46 +28,46 @@
(dlambda (dlambda
(:inc-apples () (:inc-apples ()
(funcall apple-counter :inc)) (call apple-counter :inc))
(:dec-apples () (:dec-apples ()
(funcall apple-counter :dec)) (call apple-counter :dec))
(:get-apples () (:get-apples ()
(funcall apple-counter :get)) (call apple-counter :get))
(:set-apples (value) (:set-apples (value)
(funcall apple-counter :set value)) (call apple-counter :set value))
(:inc-bananas () (:inc-bananas ()
(funcall banana-counter :inc)) (call banana-counter :inc))
(:dec-bananas () (:dec-bananas ()
(funcall banana-counter :dec)) (call banana-counter :dec))
(:get-bananas () (:get-bananas ()
(funcall banana-counter :get)) (call banana-counter :get))
(:set-bananas (value) (:set-bananas (value)
(funcall banana-counter :set value)) (call banana-counter :set value))
(:inc-coconuts () (:inc-coconuts ()
(funcall coconut-counter :inc)) (call coconut-counter :inc))
(:dec-coconuts () (:dec-coconuts ()
(funcall coconut-counter :dec)) (call coconut-counter :dec))
(:get-coconuts () (:get-coconuts ()
(funcall coconut-counter :get)) (call coconut-counter :get))
(:set-coconuts (value) (:set-coconuts (value)
(funcall coconut-counter :set value)) (call coconut-counter :set value))
(t (&rest arguments) (t (&rest arguments)
(list (list
(list 'apples (funcall apple-counter :get)) (list 'apples (call apple-counter :get))
(list 'bananas (funcall banana-counter :get)) (list 'bananas (call banana-counter :get))
(list 'coconuts (funcall coconut-counter :get)))))))) (list 'coconuts (call coconut-counter :get))))))))
; Create an instance ; Create an instance
@ -82,7 +82,7 @@
; Another way ; Another way
; ;
; usage: ; usage:
; ~ (funcall my-fruits2 :set-apples 23) ; ~ (call my-fruits2 :set-apples 23)
; 23 ; 23
; ;
(setf my-fruits2 (fruit-counter 10000)) (setq my-fruits2 (fruit-counter 10000))

29
lisp/object/this.lisp
View File

@ -1,37 +1,36 @@
(load "../lang/dlambda.lisp") (load "../lang/dlambda.lisp")
(defun counter (initial-count) (defun counter (initial-count)
(let ((count initial-count) (let ((this) (name)
(name nil) (count initial-count))
(this nil))
(setf name "Counter") (setq name "Counter")
(setf this (setq this
(eval (eval
(dlambda (dlambda
(:inc () (:inc ()
(setf count (+ count 1))) (setq count (+ count 1)))
(:inc-3 () (:inc-3 ()
(funcall this :inc) (call this :inc)
(funcall this :inc) (call this :inc)
(funcall this :inc)) (call this :inc))
(:dec () (:dec ()
(setf count (- count 1))) (setq count (- count 1)))
(:dec-3 () (:dec-3 ()
(funcall this :dec) (call this :dec)
(funcall this :dec) (call this :dec)
(funcall this :dec)) (call this :dec))
(:get () (:get ()
count) count)
(:set (value) (:set (value)
(setf count value)) (setq count value))
(t () (t ()
(cons name count))))))) (cons name count)))))))
@ -40,4 +39,4 @@
(let ((instance (counter 0))) (let ((instance (counter 0)))
(defun my-counter (&rest args) (apply instance args))) (defun my-counter (&rest args) (apply instance args)))
(setf my-counter2 (counter 10000)) (setq my-counter2 (counter 10000))

4
lisp/unit/unit-test.lisp
View File

@ -1,5 +1,5 @@
(defun run-unit-test (unit-test) (defun run-unit-test (unit-test)
(if (funcall unit-test) (if (call unit-test)
(progn (progn
(print (cons t unit-test)) (print (cons t unit-test))
t) t)
@ -18,7 +18,7 @@
(eval (cons 'and (run-test-suite test-suite)))) (eval (cons 'and (run-test-suite test-suite))))
(defun assert (comparison expected actual) (defun assert (comparison expected actual)
(if (funcall comparison expected actual) (if (call comparison expected actual)
t t
(progn (progn
(print (list expected 'is 'not comparison actual)) (print (list expected 'is 'not comparison actual))