Skip to content

Instantly share code, notes, and snippets.

Created December 19, 2015 15:32
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save eshamster/c08e80732ee727ffc71e to your computer and use it in GitHub Desktop.
(defpsmacro defstruct (name-and-options &rest slot-description)
"This is the tiny subset of defsturt in terms of syntax.
name-and-options::= structure-name | (structure-name (:include included-structure-name))
slot-description::= slot-name | (slot-name slot-init-form)"
(bind:bind (((:values name parent)
(parse-defstruct-name-and-options name-and-options))
(parse-defstruct-slot-description slot-description)))
(setf slots (merge-defstruct-slots parent slots))
(register-defstruct-slots name slots)
;; JavaScriptにおけるクラス定義
(defun ,name ()
,@(mapcar (lambda (slot)
`(setf (@ this ,(car slot)) ,(cadr slot)))
;; 構造体を作成するmake-xxx関数の定義
(defun ,(symbolicate 'make- name) (&key ,@slots)
(let ((result (new (,name))))
,@(mapcar (lambda (elem)
`(setf (@ result ,(car elem)) ,(car elem)))
;; アクセサの定義(ここのdefmacroが問題)
,@(mapcar (lambda (slot)
`(defmacro ,(symbolicate name '- (car slot)) (obj)
`(@ ,obj ,',(car slot))))
;; 型判別用のxxx-p関数の定義
(defun ,(symbolicate name '-p) (obj)
(instanceof obj ,name))
;; JavaScriptにおける継承関係の設定
,(when parent
`(funcall (lambda ()
(defun temp-ctor ())
(setf (@ temp-ctor prototype) (@ ,parent prototype))
(setf (@ ,name super-class_) (@ ,parent prototype))
(setf (@ ,name prototype) (new (temp-ctor)))
(setf (@ ,name prototype constructor) ,name)))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment