Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2009-02-15

第4回Smiley Hackathon(仮)に参加してきました!

| 22:49 | 第4回Smiley Hackathon(仮)に参加してきました! - わだばLisperになる を含むブックマーク はてなブックマーク - 第4回Smiley Hackathon(仮)に参加してきました! - わだばLisperになる

昨日2/14日に、Smiley Hackathon(仮)に参戦してきました。

総勢、15、6名の参加だったと思いますが、Perlの方が殆どで、Lisperしか知らない自分には新鮮でした!

今回の自分のテーマは、以前にちょっと作っていたCLOSでMoose風の構文を真似るというものでしたが、割と話に熱中していたのでコードは書けてませんでした(笑)

以前のものからあまり進んでませんし、その場しのぎでごちゃごちゃ追加しただけですが、一応貼っておきます。

次回に参加する時は、スロットの遅延評価機能を付けたいです。

(defpackage :moose
  (:use :cl))

(in-package :moose)

(defpackage :moose
  (:use :cl))

(in-package :moose)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun get-hases (attributes)
    (remove :has attributes :key #'car :test-not #'eq))
  
  (defun get-subs (attributes)
    (remove :sub attributes :key #'car :test-not #'eq))
  
  (defun ensure-has-attributes (class-name attributes)
    (declare (ignore class-name))
    (mapcar (lambda (x)
              (let ((has (getf x :has))
                    (is (getf x :is))
                    (isa (getf x :isa)))
                `(,has
                  ,@(and is (list 
                             (case is
                               (rw :accessor)
                               (ro :reader)
                               (otherwise (error "malformed attributes")))
                                        ;(intern (format nil "~:@(~A.~A~)" class-name has))
                             has
                             ))
                  ,@(and isa (list :type isa)))))
            (get-hases attributes)))
  
  (defun ensure-sub-attributes (class-name attributes)
    (mapcar (lambda (x)
              (let* ((args (cdr x)))
                `(defmethod ,(first args) ((self ,class-name) ,@(second args)) ,@(cddr args))))
            (get-subs attributes)))
  
  (defun get-afters (attributes)
    (remove :after attributes :key #'car :test-not #'eq))

  (defun get-befores (attributes)
    (remove :before attributes :key #'car :test-not #'eq))

  (defun get-arounds (attributes)
    (remove :around attributes :key #'car :test-not #'eq))

  (defun ensure-after-attributes (class-name attributes)
    (mapcar (lambda (x)
              (let ((args (cdr x)))
                `(defmethod ,(first args) :after ((self ,class-name) ,@(second args)) ,@(cddr args))))
            (get-afters attributes)))

  (defun ensure-before-attributes (class-name attributes)
    (mapcar (lambda (x)
              (let ((args (cdr x)))
                `(defmethod ,(first args) :before ((self ,class-name) ,@(second args)) ,@(cddr args))))
            (get-befores attributes)))

  (defun ensure-around-attributes (class-name attributes)
    (mapcar (lambda (x)
              (let ((args (cdr x)))
                `(defmethod ,(first args) :around ((self ,class-name) ,@(second args))
                   (macrolet ((super (&rest args)
                                `(call-next-method ,@args)))
                     ,@(cddr args)))))
            (get-arounds attributes))) )

(defmacro defmoose (name (&rest extends) &rest attributes)
  `(progn
     (defclass ,name ,extends
       ,(ensure-has-attributes name attributes))
     ,@(ensure-sub-attributes name attributes)
     ,@(ensure-after-attributes name attributes)
     ,@(ensure-before-attributes name attributes)
     ,@(ensure-around-attributes name attributes)))

;; new
(setf (fdefinition 'new)
      (fdefinition 'make-instance))
>describe
;#<POINT {100DB9CF81}> is an instance of class #<STANDARD-CLASS POINT>.
;The following slots have :INSTANCE allocation:
; X    30
; Y    0

(defmoose point-3d (point)
  (:has z :is rw)
  (:after clear ()
          (setf (z self) 0)))

(let ((p (make-instance 'point-3d)))
  (clear p)
  (setf (x p) 30)
  p)

;>>describe
;#<POINT-3D {100E1D9431}> is an instance of class #<STANDARD-CLASS POINT-3D>.
;The following slots have :INSTANCE allocation:
; X    30
; Y    0
; Z    0
;; メソッド結合 before after

;; プライマリ
(defmoose hello ()
  (:has mesg :is rw)
  (:sub mesg ()
        (format t "~&こんにちは!~%")))

(mesg (new 'hello))
;-> こんにちは!
;=> NIL

;; before追加
(defmoose hello ()
  (:has mesg :is rw)
  (:sub mesg ()
        (format t "~&こんにちは!~%"))
  (:before mesg ()
           (format t "~&あー、テステス~%")))

(mesg (new 'hello))
;-> あー、テステス
;   こんにちは!
;=> NIL

;; after追加
(defmoose hello ()
  (:has mesg :is rw)
  (:sub mesg ()
        (format t "~&こんにちは!~%"))
  (:before mesg ()
           (format t "~&あー、テステス~%"))
  (:after mesg ()
          (format t "~&さようなら~%")))

(mesg (new 'hello))
;-> あー、テステス
;   こんにちは!
;   さようなら
;NIL

;; メソッド結合 around

;; プライマリ
(defmoose around-hello ()
  (:has mes :is rw)
  (:sub mes ()
        (format t "~&こんにちは!~%")))

(mes (new 'around-hello))
;-> こんにちは!
;=> NIL

(defmoose around-hello ()
  (:has mes :is rw)
  (:sub mes ()
        (format t "~&こんにちは!~%"))
  (:around mes ()
           (format t "~&** ご紹介します! **~%")
           (super)                      ;プライマリを呼ぶ
           (format t "~&** ありがとうございました! **~%")))

(mes (new 'around-hello))
;-> ** ご紹介します! **
;   こんにちは!
;   ** ありがとうございました! **
;=> NIL